utils/terminfo.cmx : utils/terminfo.cmi
utils/warnings.cmo : utils/warnings.cmi
utils/warnings.cmx : utils/warnings.cmi
+parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
+ parsing/location.cmi parsing/asttypes.cmi
parsing/asttypes.cmi : parsing/location.cmi
parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
parsing/location.cmi : utils/warnings.cmi
parsing/location.cmi
parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \
parsing/asttypes.cmi
+parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \
+ parsing/asttypes.cmi
parsing/printast.cmi : parsing/parsetree.cmi
parsing/syntaxerr.cmi : parsing/location.cmi
+parsing/ast_mapper.cmo : parsing/parsetree.cmi parsing/longident.cmi \
+ parsing/location.cmi utils/config.cmi parsing/asttypes.cmi \
+ parsing/ast_mapper.cmi
+parsing/ast_mapper.cmx : parsing/parsetree.cmi parsing/longident.cmx \
+ parsing/location.cmx utils/config.cmx parsing/asttypes.cmi \
+ parsing/ast_mapper.cmi
parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
parsing/location.cmi parsing/lexer.cmi
parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \
parsing/asttypes.cmi parsing/parser.cmi
+parsing/pprintast.cmo : parsing/parsetree.cmi parsing/longident.cmi \
+ parsing/location.cmi parsing/asttypes.cmi parsing/pprintast.cmi
+parsing/pprintast.cmx : parsing/parsetree.cmi parsing/longident.cmx \
+ parsing/location.cmx parsing/asttypes.cmi parsing/pprintast.cmi
parsing/printast.cmo : parsing/parsetree.cmi parsing/longident.cmi \
parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi
parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \
parsing/asttypes.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
typing/path.cmi parsing/longident.cmi parsing/location.cmi \
- typing/ident.cmi utils/consistbl.cmi typing/annot.cmi
+ typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi
+typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/ident.cmi :
typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
typing/env.cmi
typing/oprint.cmi : typing/outcometree.cmi
typing/outcometree.cmi : parsing/asttypes.cmi
-typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/env.cmi parsing/asttypes.cmi
typing/path.cmi : typing/ident.cmi
typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/primitive.cmi :
typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
- typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi
+ typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
+ typing/env.cmi
typing/printtyped.cmi : typing/typedtree.cmi
typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
typing/annot.cmi
typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
+typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
+typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includemod.cmi typing/ident.cmi typing/env.cmi
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/env.cmi parsing/asttypes.cmi
typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \
- typing/btype.cmi
+ typing/ident.cmi typing/btype.cmi
typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \
- typing/btype.cmi
+ typing/ident.cmx typing/btype.cmi
typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \
utils/config.cmi typing/cmi_format.cmi
typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \
utils/config.cmx typing/cmi_format.cmi
-typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi utils/misc.cmi \
- parsing/location.cmi parsing/lexer.cmi typing/env.cmi utils/config.cmi \
- typing/cmi_format.cmi utils/clflags.cmi parsing/asttypes.cmi \
- typing/cmt_format.cmi
-typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx utils/misc.cmx \
- parsing/location.cmx parsing/lexer.cmx typing/env.cmx utils/config.cmx \
- typing/cmi_format.cmx utils/clflags.cmx parsing/asttypes.cmi \
- typing/cmt_format.cmi
+typing/cmt_format.cmo : typing/types.cmi typing/typedtreeMap.cmi \
+ typing/typedtree.cmi utils/misc.cmi parsing/location.cmi \
+ parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \
+ utils/clflags.cmi typing/cmt_format.cmi
+typing/cmt_format.cmx : typing/types.cmx typing/typedtreeMap.cmx \
+ typing/typedtree.cmx utils/misc.cmx parsing/location.cmx \
+ parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \
+ utils/clflags.cmx typing/cmt_format.cmi
typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \
utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \
utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/ctype.cmi
-typing/datarepr.cmo : typing/types.cmi typing/predef.cmi utils/misc.cmi \
+typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \
typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \
typing/datarepr.cmi
-typing/datarepr.cmx : typing/types.cmx typing/predef.cmx utils/misc.cmx \
+typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/datarepr.cmi
typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
typing/cmi_format.cmi utils/clflags.cmi typing/btype.cmi \
- parsing/asttypes.cmi typing/annot.cmi typing/env.cmi
+ parsing/asttypes.cmi typing/env.cmi
typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
- parsing/asttypes.cmi typing/annot.cmi typing/env.cmi
+ parsing/asttypes.cmi typing/env.cmi
+typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
+ typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
+ parsing/asttypes.cmi typing/envaux.cmi
+typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
+ typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
+ parsing/asttypes.cmi typing/envaux.cmi
typing/ident.cmo : typing/ident.cmi
typing/ident.cmx : typing/ident.cmi
typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi typing/outcometree.cmi \
- typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \
- typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
- parsing/asttypes.cmi typing/printtyp.cmi
+ typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
+ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+ typing/printtyp.cmi
typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
typing/predef.cmx typing/path.cmx typing/outcometree.cmi \
- typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \
- typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
- parsing/asttypes.cmi typing/printtyp.cmi
+ typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
+ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+ typing/printtyp.cmi
typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
parsing/asttypes.cmi typing/printtyped.cmi
typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
+typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \
+ typing/typedtreeIter.cmi
+typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \
+ typing/typedtreeIter.cmi
+typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \
+ parsing/asttypes.cmi typing/typedtreeMap.cmi
+typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
+ parsing/asttypes.cmi typing/typedtreeMap.cmi
typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
typing/typemod.cmi
-typing/types.cmo : typing/primitive.cmi typing/path.cmi utils/misc.cmi \
+typing/types.cmo : typing/primitive.cmi typing/path.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
parsing/asttypes.cmi typing/types.cmi
-typing/types.cmx : typing/primitive.cmx typing/path.cmx utils/misc.cmx \
+typing/types.cmx : typing/primitive.cmx typing/path.cmx \
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
parsing/asttypes.cmi typing/types.cmi
typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \
bytecomp/runtimedef.cmi :
bytecomp/simplif.cmi : bytecomp/lambda.cmi
bytecomp/switch.cmi :
-bytecomp/symtable.cmi : typing/ident.cmi bytecomp/cmo_format.cmi
+bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \
+ bytecomp/cmo_format.cmi
bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
-bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \
- typing/primitive.cmi typing/path.cmi parsing/location.cmi \
- bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
+bytecomp/translcore.cmi : typing/typedtree.cmi typing/primitive.cmi \
+ typing/path.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
+ parsing/asttypes.cmi
bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi
bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi
bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \
- bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \
- bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \
- utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \
- utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \
- bytecomp/bytelink.cmi
+ bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi typing/ident.cmi \
+ bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \
+ bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \
+ bytecomp/bytesections.cmi bytecomp/bytelink.cmi
bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \
- bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \
- bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \
- utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \
- utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \
- bytecomp/bytelink.cmi
+ bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \
+ bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \
+ bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \
+ bytecomp/bytesections.cmx bytecomp/bytelink.cmi
bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
typing/subst.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \
bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \
bytecomp/symtable.cmi
bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \
typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
- typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.cmi \
+ typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \
typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi
bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \
typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \
- typing/path.cmx utils/misc.cmx bytecomp/matching.cmx parsing/location.cmx \
+ typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \
bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \
typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi
-bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \
- typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \
- typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \
- bytecomp/matching.cmi parsing/longident.cmi parsing/location.cmi \
- bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
- utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
- bytecomp/translcore.cmi
-bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
- typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \
- typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \
- bytecomp/matching.cmx parsing/longident.cmx parsing/location.cmx \
- bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
- utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
- bytecomp/translcore.cmi
+bytecomp/translcore.cmo : utils/warnings.cmi typing/types.cmi \
+ bytecomp/typeopt.cmi typing/typedtree.cmi bytecomp/translobj.cmi \
+ typing/primitive.cmi typing/predef.cmi typing/path.cmi \
+ typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
+ parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
+ typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
+ typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
+bytecomp/translcore.cmx : utils/warnings.cmx typing/types.cmx \
+ bytecomp/typeopt.cmx typing/typedtree.cmx bytecomp/translobj.cmx \
+ typing/primitive.cmx typing/predef.cmx typing/path.cmx \
+ typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
+ parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
+ typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
+ typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
bytecomp/translobj.cmi
bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
- typing/primitive.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
- bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
- parsing/asttypes.cmi bytecomp/typeopt.cmi
+ typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi typing/ident.cmi \
+ typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi
bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
- typing/primitive.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
- bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
- parsing/asttypes.cmi bytecomp/typeopt.cmi
+ typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \
+ typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi
asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi
asmcomp/asmlibrarian.cmi :
asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \
asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
- asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \
- utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi asmcomp/liveness.cmi \
- asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \
- asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \
- asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi
+ asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \
+ typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \
+ asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \
+ asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \
+ asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \
+ asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \
+ asmcomp/asmgen.cmi
asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \
asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \
asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
- asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \
- utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx asmcomp/liveness.cmx \
- asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \
- asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \
- asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \
- asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi
+ asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \
+ typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \
+ asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \
+ asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \
+ asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \
+ asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \
+ asmcomp/asmgen.cmi
asmcomp/asmlibrarian.cmo : utils/misc.cmi utils/config.cmi \
asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \
asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \
asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \
utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
- utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
- typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \
- utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
+ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
+ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
+ utils/clflags.cmi utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
asmcomp/asmpackager.cmi
asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
- utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
- typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \
- asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \
- utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
+ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
+ utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
+ utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
asmcomp/asmpackager.cmi
asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
- parsing/asttypes.cmi asmcomp/closure.cmi
+ parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi
asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
- parsing/asttypes.cmi asmcomp/closure.cmi
+ parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi
asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
asmcomp/cmm.cmi
asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \
asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo : asmcomp/reg.cmi asmcomp/linearize.cmi \
- asmcomp/debuginfo.cmi utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi \
- asmcomp/arch.cmo asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx : asmcomp/reg.cmx asmcomp/linearize.cmx \
- asmcomp/debuginfo.cmx utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx \
- asmcomp/arch.cmx asmcomp/emitaux.cmi
-asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
- asmcomp/mach.cmi asmcomp/interf.cmi
-asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
- asmcomp/mach.cmx asmcomp/interf.cmi
+asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
+ utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
+ utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
+asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
+ asmcomp/interf.cmi
+asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
+ asmcomp/interf.cmi
asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
asmcomp/linearize.cmi
asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
asmcomp/arch.cmx asmcomp/mach.cmi
asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \
- typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/clambda.cmi \
- parsing/asttypes.cmi asmcomp/printclambda.cmi
+ typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
+ asmcomp/printclambda.cmi
asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \
- typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/clambda.cmx \
- parsing/asttypes.cmi asmcomp/printclambda.cmi
+ typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
+ asmcomp/printclambda.cmi
asmcomp/printcmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/cmm.cmi asmcomp/printcmm.cmi
asmcomp/printcmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
-asmcomp/schedgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
+asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
-asmcomp/schedgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
+asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/schedgen.cmi
asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi
asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \
asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/selectgen.cmi
-asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/reg.cmi \
- asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi \
- utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi
-asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/reg.cmx \
- asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx \
- utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi
+asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
+ utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi \
+ asmcomp/arch.cmo asmcomp/selection.cmi
+asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
+ utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \
+ asmcomp/arch.cmx asmcomp/selection.cmi
asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/split.cmi
asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/split.cmi
-driver/compile.cmi : typing/env.cmi
+driver/compenv.cmi :
+driver/compile.cmi :
+driver/compmisc.cmi : typing/env.cmi
driver/errors.cmi :
driver/main.cmi :
driver/main_args.cmi :
-driver/optcompile.cmi : typing/env.cmi
+driver/optcompile.cmi :
driver/opterrors.cmi :
driver/optmain.cmi :
driver/pparse.cmi :
+driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \
+ utils/config.cmi utils/clflags.cmi driver/compenv.cmi
+driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \
+ utils/config.cmx utils/clflags.cmx driver/compenv.cmi
driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
- typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \
- bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
- bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \
- parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \
- typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \
+ typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
+ typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
+ typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \
+ parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \
+ parsing/parse.cmi utils/misc.cmi parsing/location.cmi \
+ typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \
+ utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
- typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \
- bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
- bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \
- parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \
- typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \
+ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
+ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \
+ typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \
+ parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \
+ parsing/parse.cmx utils/misc.cmx parsing/location.cmx \
+ typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \
+ utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi
+driver/compmisc.cmo : utils/misc.cmi typing/ident.cmi typing/env.cmi \
+ utils/config.cmi driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi
+driver/compmisc.cmx : utils/misc.cmx typing/ident.cmx typing/env.cmx \
+ utils/config.cmx driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi
driver/errors.cmo : utils/warnings.cmi typing/typetexp.cmi \
typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \
bytecomp/bytelibrarian.cmx driver/errors.cmi
driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi driver/errors.cmi utils/config.cmi \
- driver/compile.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
- bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi
+ driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \
+ utils/clflags.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
+ bytecomp/bytelibrarian.cmi driver/main.cmi
driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
parsing/location.cmx driver/errors.cmx utils/config.cmx \
- driver/compile.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
- bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
+ driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \
+ utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
+ bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
- typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \
- bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
- parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \
- parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
- asmcomp/compilenv.cmi utils/clflags.cmi utils/ccomp.cmi \
- asmcomp/asmgen.cmi driver/optcompile.cmi
+ typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
+ typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
+ typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
+ parsing/pprintast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \
+ parsing/location.cmi typing/includemod.cmi typing/env.cmi \
+ utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \
+ driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi asmcomp/asmgen.cmi \
+ driver/optcompile.cmi
driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
- typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \
- bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
- parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \
- parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
- asmcomp/compilenv.cmx utils/clflags.cmx utils/ccomp.cmx \
- asmcomp/asmgen.cmx driver/optcompile.cmi
+ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
+ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \
+ typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \
+ parsing/pprintast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \
+ parsing/location.cmx typing/includemod.cmx typing/env.cmx \
+ utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \
+ driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx asmcomp/asmgen.cmx \
+ driver/optcompile.cmi
driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \
typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \
driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
- utils/clflags.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \
- asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi
+ driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
+ asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \
+ asmcomp/arch.cmo driver/optmain.cmi
driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
- utils/clflags.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \
- asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi
+ driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
+ asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
+ asmcomp/arch.cmx driver/optmain.cmi
driver/pparse.cmo : utils/misc.cmi parsing/location.cmi utils/clflags.cmi \
utils/ccomp.cmi driver/pparse.cmi
driver/pparse.cmx : utils/misc.cmx parsing/location.cmx utils/clflags.cmx \
parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \
typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi
toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \
- typing/printtyp.cmi typing/path.cmi toplevel/opttoploop.cmi \
- utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \
- typing/ctype.cmi utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \
+ typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \
+ parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+ utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \
toplevel/opttopdirs.cmi
toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \
- typing/printtyp.cmx typing/path.cmx toplevel/opttoploop.cmx \
- utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \
- typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \
+ typing/printtyp.cmx toplevel/opttoploop.cmx utils/misc.cmx \
+ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+ utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \
toplevel/opttopdirs.cmi
toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
- bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
- bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \
- typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
- typing/outcometree.cmi driver/opterrors.cmi driver/optcompile.cmi \
- typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
- parsing/location.cmi parsing/lexer.cmi bytecomp/lambda.cmi \
+ bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
+ typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
+ typing/predef.cmi parsing/pprintast.cmi typing/path.cmi \
+ parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \
+ driver/opterrors.cmi typing/oprint.cmi utils/misc.cmi \
+ parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \
- asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \
- asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi
+ driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
+ typing/btype.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
+ toplevel/opttoploop.cmi
toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
- bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
- bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \
- typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
- typing/outcometree.cmi driver/opterrors.cmx driver/optcompile.cmx \
- typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
- parsing/location.cmx parsing/lexer.cmx bytecomp/lambda.cmx \
+ bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyped.cmx \
+ typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \
+ typing/predef.cmx parsing/pprintast.cmx typing/path.cmx \
+ parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \
+ driver/opterrors.cmx typing/oprint.cmx utils/misc.cmx \
+ parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \
- asmcomp/compilenv.cmx utils/clflags.cmx typing/btype.cmx \
- asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi
+ driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
+ typing/btype.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
+ toplevel/opttoploop.cmi
toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \
utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.cmi \
- utils/clflags.cmi toplevel/opttopmain.cmi
+ driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi
toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \
utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \
- utils/clflags.cmx toplevel/opttopmain.cmi
+ driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi
toplevel/opttopstart.cmo : toplevel/opttopmain.cmi
toplevel/opttopstart.cmx : toplevel/opttopmain.cmx
toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \
toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \
typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \
- typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \
- parsing/printast.cmi typing/predef.cmi typing/path.cmi \
+ typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
+ bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \
+ parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \
typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \
parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \
typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
- utils/config.cmi driver/compile.cmi utils/clflags.cmi \
+ utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \
bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi
toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \
typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
bytecomp/translmod.cmx bytecomp/symtable.cmx bytecomp/simplif.cmx \
- typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \
- parsing/printast.cmx typing/predef.cmx typing/path.cmx \
+ typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
+ bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \
+ parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \
parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \
typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \
parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \
typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
- utils/config.cmx driver/compile.cmx utils/clflags.cmx \
+ utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \
bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi
toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \
- parsing/location.cmi driver/errors.cmi utils/config.cmi utils/clflags.cmi \
- toplevel/topmain.cmi
+ parsing/location.cmi driver/errors.cmi utils/config.cmi \
+ driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi
toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \
- parsing/location.cmx driver/errors.cmx utils/config.cmx utils/clflags.cmx \
- toplevel/topmain.cmi
+ parsing/location.cmx driver/errors.cmx utils/config.cmx \
+ driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi
toplevel/topstart.cmo : toplevel/topmain.cmi
toplevel/topstart.cmx : toplevel/topmain.cmx
toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \
_boot_log1
_boot_log2
_build
+_start
+_buildtest
_log
myocamlbuild_config.ml
ocamlbuild-mixed-boot
+OCaml 4.01.0:
+-------------
+
+(Changes that can break existing programs are marked with a "*")
+
+Other libraries:
+- Labltk: updated to Tcl/Tk 8.6.
+
+Type system:
+- PR#5759: use well-disciplined type information propagation to
+ disambiguate label and constructor names
+ (Jacques Garrigue, Alain Frisch and Leo P. White)
+* Propagate type information towards pattern-matching, even in the presence of
+ polymorphic variants (discarding only information about possibly-present
+ constructors). As a result, matching against absent constructors is no longer
+ allowed for exact and fixed polymorphic variant types.
+ (Jacques Garrigue)
+* PR#6035: Reject multiple declarations of the same method or instance variable
+ in an object
+ (Alain Frisch)
+
+Compilers:
+- PR#5861: raise an error when multiple private keywords are used in type
+ declarations
+ (Hongbo Zhang)
+- PR#5634: parsetree rewriter (-ppx flag)
+ (Alain Frisch)
+- ocamldep now supports -absname
+ (Alain Frisch)
+- PR#5768: On "unbound identifier" errors, use spell-checking to suggest names
+ present in the environment
+ (Gabriel Scherer)
+- ocamlc has a new option -dsource to visualize the parsetree
+ (Alain Frisch, Hongbo Zhang)
+- tools/eqparsetree compares two parsetree ignoring location
+ (Hongbo Zhang)
+- ocamlopt now uses clang as assembler on OS X if available, which enables
+ CFI support for OS X.
+ (Benedikt Meurer)
+- Added a new -short-paths option, which attempts to use the shortest
+ representation for type constructors inside types, taking open modules
+ into account. This can make types much more readable if your code
+ uses lots of functors.
+ (Jacques Garrigue)
+- PR#5986: added flag -compat-32 to ocamlc, ensuring that the generated
+ bytecode executable can be loaded on 32-bit hosts.
+ (Xavier Leroy)
+- PR#5980: warning on open statements which shadow an existing
+ identifier (if it is actually used in the scope of the open); new
+ open! syntax to silence it locally
+ (Alain Frisch, thanks to a report of Daniel Bünzli)
+* warning 3 is extended to warn about other deprecated features:
+ - ISO-latin1 characters in identifiers
+ - uses of the (&) and (or) operators instead of (&&) and (||)
+ (Damien Doligez)
+- Experimental OCAMLPARAM for ocamlc and ocamlopt
+ (Fabrice Le Fessant)
+- PR#5571: incorrect ordinal number in error message
+ (Alain Frisch, report by John Carr)
+- PR#6073: add signature to Tstr_include
+ (patch by Leo P. White)
+
+Standard library:
+- PR#5899: expose a way to inspect the current call stack,
+ Printexc.get_callstack
+ (Gabriel Scherer, Jacques-Henri Jourdan, Alain Frisch)
+- PR#5986: new flag Marshal.Compat_32 for the serialization functions
+ (Marshal.to_*), forcing the output to be readable on 32-bit hosts.
+ (Xavier Leroy)
+- infix application operators |> and @@ in Pervasives
+ (Fabrice Le Fessant)
+
+Other libraries:
+- PR#5568: add O_CLOEXEC flag to Unix.openfile, so that the returned
+ file descriptor is created in close-on-exec mode
+ (Xavier Leroy)
+
+Runtime system:
+* PR#6019: more efficient implementation of caml_modify() and caml_initialize().
+ The new implementations are less lenient than the old ones: now,
+ the destination pointer of caml_modify() must point within the minor or
+ major heaps, and the destination pointer of caml_initialize() must
+ point within the major heap.
+ (Xavier Leroy, from an experiment by Brian Nigito, with feedback
+ from Yaron Minsky and Gerd Stolpmann)
+
+Internals:
+- Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary
+ as part of compilerlibs, to be used on bin-annot files.
+ (Fabrice Le Fessant)
+- The test suite can now be run without installing OCaml first.
+ (Damien Doligez)
+
+Bug fixes:
+- PR#3236: Document the fact that queues are not thread-safe
+ (Damien Doligez)
+- PR#3468: (part 1) Sys_error documentation
+ (Damien Doligez)
+- PR#3679: Warning display problems
+ (Fabrice Le Fessant)
+- PR#3963: Graphics.wait_next_event in Win32 hangs if window closed
+ (Damien Doligez)
+- PR#4079: Queue.copy is now tail-recursive
+ (patch by Christophe Papazian)
+- PR#4138: Documentation for Unix.mkdir
+ (Damien Doligez)
+- PR#4469: emacs mode: caml-set-compile-command is annoying with ocamlbuild
+ (Daniel Bünzli)
+- PR#4485: Graphics: Keyboard events incorrectly delivered in native code
+ (Damien Doligez, report by Sharvil Nanavati)
+- PR#4502: ocamlbuild now reliably excludes the build-dir from hygiene check
+ (Gabriel Scherer, report by Romain Bardou)
+- PR#4762: ?? is not used at all, but registered as a lexer token
+ (Alain Frisch)
+- PR#4788: wrong error message when executable file is not found for backtrace
+ (Damien Doligez, report by Claudio Sacerdoti Coen)
+- PR#4812: otherlibs/unix: add extern int code_of_unix_error (value error);
+ (Goswin von Berdelow)
+- PR#4887: input_char after close_in crashes ocaml (msvc runtime)
+ (Alain Frisch and Christoph Bauer, report by ygrek)
+- PR#4994: ocaml-mode doesn't work with xemacs21
+ (Damien Doligez, report by Stéphane Glondu)
+- PR#5098: creating module values may lead to memory leaks
+ (Alain Frisch, report by Milan Stanojević)
+- PR#5102: ocamlbuild fails when using an unbound variable in rule dependency
+ (Xavier Clerc, report by Daniel Bünzli)
+* PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails,
+ rather than raising 'Not_found'
+ (ygrek)
+- PR#5121: %( %) in Format module seems to be broken
+ (Pierre Weis, first patch by Valentin Gatien-Baron, report by Khoo Yit Phang)
+- PR#5178: document in INSTALL how to build a 32-bit version under Linux x86-64
+ (Benjamin Monate)
+- PR#5212: Improve ocamlbuild error messages of _tags parser
+ (ygrek)
+- PR#5240: register exception printers for Unix.Unix_error and Dynlink.Error
+ (Jérémie Dimino)
+- PR#5300: ocamlbuild: verbose parameter should implicitly set classic display
+ (Xavier Clerc, report by Robert Jakob)
+- PR#5327: (Windows) Unix.select blocks if same socket listed in first and
+ third arguments
+ (David Allsopp, displaying impressive MSDN skills)
+- PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound)
+ (Jacques Garrigue)
+- PR#5350: missing return code checks in the runtime system
+ (Xavier Leroy)
+- PR#5468: ocamlbuild should preserve order of parametric tags
+ (Wojciech Meyer, report by Dario Texeira)
+- PR#5551: Avoid repeated lookups for missing cmi files
+ (Alain Frisch)
+- PR#5552: unrecognized gcc option -no-cpp-precomp
+ (Damien Doligez, report by Markus Mottl)
+- PR#5580: missed opportunities for constant propagation
+ (Xavier Leroy and John Carr)
+- PR#5611: avoid clashes betwen .cmo files and output files during linking
+ (Wojciech Meyer)
+- PR#5662: typo in md5.c
+ (Olivier Andrieu)
+- PR#5673: type equality in a polymorphic field
+ (Jacques Garrigue, report by Jean-Louis Giavitto)
+- PR#5674: Methods call are 2 times slower with 4.00 than with 3.12
+ (Jacques Garrigue, Gabriel Scherer, report by Jean-Louis Giavitto)
+- PR#5694: Exception raised by type checker
+ (Jacques Garrigue, report by Markus Mottl)
+- PR#5695: remove warnings on sparc code emitter
+ (Fabrice Le Fessant)
+- PR#5697: better location for warnings on statement expressions
+ (Dan Bensen)
+- PR#5698: remove harcoded limit of 200000 labels in emitaux.ml
+ (Fabrice Le Fessant, report by Marcin Sawicki)
+- PR#5702: bytecomp/bytelibrarian lib_sharedobjs was defined but never used
+ (Hongbo Zhang, Fabrice Le Fessant)
+- PR#5708: catch Failure"int_of_string" in ocamldebug
+ (Fabrice Le Fessant, report by user 'schommer')
+- PR#5712: (9) new option -bin-annot is not documented
+ (Damien Doligez, report by Hendrik Tews)
+- PR#5731: instruction scheduling forgot to account for destroyed registers
+ (Xavier Leroy, Benedikt Meurer, reported by Jeffrey Scofield)
+- PR#5734: improved Win32 implementation of Unix.gettimeofday
+ (David Allsopp)
+- PR#5735: %apply and %revapply not first class citizens
+ (Fabrice Le Fessant, reported by Jun Furuse)
+- PR#5738: first class module patterns not handled by ocamldep
+ (Fabrice Le Fessant, Jacques Garrigue, reported by Hongbo Zhang)
+- PR#5739: Printf.printf "%F" (-.nan) returns -nan
+ (Xavier Leroy, David Allsopp, reported by Samuel Mimram)
+- PR#5741: make pprintast.ml in compiler_libs
+ (Alain Frisch, Hongbo Zhang)
+- PR#5747: 'unused open' warning not given when compiling with -annot
+ (Alain Frisch, reported by Valentin Gatien-Baron)
+- PR#5752: missing dependencies at byte-code link with mlpack
+ (Wojciech Meyer, Nicholas Lucaroni)
+- PR#5763: ocamlbuild does not give correct flags when running menhir
+ (Gabriel Scherer, reported by Philippe Veber)
+- PR#5765: ocamllex doesn't preserve line directives
+ (Damien Doligez, reported by Martin Jambon)
+- PR#5770: Syntax error messages involving unclosed parens are sometimes
+ incorrect
+ (Michel Mauny)
+- PR#5772: problem with marshaling of mutually-recursive functions
+ (Jacques-Henri Jourdan, reported by Cédric Pasteur)
+- PR#5775: several bug fixes for tools/pprintast.ml
+ (Hongbo Zhang)
+- PR#5784: -dclambda option is ignored
+ (Pierre Chambart)
+- PR#5785: misbehaviour with abstracted structural type used as GADT index
+ (Jacques Garrigue, report by Jeremy Yallop)
+- PR#5787: Bad behavior of 'Unused ...' warnings in the toplevel
+ (Alain Frisch)
+- PR#5793: integer marshalling is inconsistent between architectures
+ (Xavier Clerc, report by Pierre-Marie Pédrot)
+- PR#5798: add ARM VFPv2 support for Raspbian (ocamlopt)
+ (Jeffrey Scofield and Anil Madhavapeddy, patch review by Benedikt Meurer)
+- PR#5802: Avoiding "let" as a value name
+ (Jacques Garrigue, report by Tiphaine Turpin)
+- PR#5805: Assert failure with warning 34 on pre-processed file
+ (Alain Frisch, report by Tiphaine Turpin)
+- PR#5806: ensure that backtrace tests are always run (testsuite)
+ (Xavier Clerc, report by user 'michi')
+- PR#5809: Generating .cmt files takes a long time, in case of type error
+ (Alain Frisch)
+- PR#5810: error in switch printing when using -dclambda
+ (Pierre Chambart)
+- PR#5811: Untypeast produces singleton tuples for constructor patterns
+ with only one argument
+ (Tiphaine Turpin)
+- PR#5813: GC not called when unmarshaling repeatedly in a tight loop (ocamlopt)
+ (Xavier Leroy, report by David Waern)
+- PR#5814: read_cmt -annot does not report internal references
+ (Alain Frisch)
+- PR#5815: Multiple exceptions in signatures gives an error
+ (Leo P. White)
+- PR#5816: read_cmt -annot does not work for partial .cmt files
+ (Alain Frisch)
+- PR#5819: segfault when using [with] on large recursive record (ocamlopt)
+ (Xavier Leroy, Damien Doligez)
+- PR#5821: Wrong record field is reported as duplicate
+ (Alain Frisch, report by Martin Jambon)
+- PR#5824: Generate more efficient code for immediate right shifts.
+ (Pierre Chambart, review by Xavier Leroy)
+- PR#5825: Add a toplevel primitive to use source file wrapped with the
+ coresponding module
+ (Grégoire Henry, Wojciech Meyer, caml-list discussion)
+- PR#5833: README.win32 can leave the wrong flexlink in the path
+ (Damien Doligez, report by William Smith)
+- PR#5835: nonoptional labeled arguments can be passed with '?'
+ (Jacques Garrigue, report by Elnatan Reisner)
+- PR#5840: improved documentation for 'Unix.lseek'
+ (Xavier Clerc, report by Matej Košík)
+- PR#5848: Assertion failure in type checker
+ (Jacques Garrigue, Alain Frisch, report by David Waern)
+- PR#5858: Assert failure during typing of class
+ (Jacques Garrigue, report by Julien Signoles)
+- PR#5865: assert failure when reporting undefined field label
+ (Jacques Garrigue, report by Anil Madhavapeddy)
+- PR#5872: Performance: Buffer.add_char is not inlined
+ (Gerd Stolpmann, Damien Doligez)
+- PR#5876: Uncaught exception with a typing error
+ (Alain Frisch, Gabriel Scherer, report by Julien Moutinho)
+- PR#5877: multiple "open" can become expensive in memory
+ (Fabrice Le Fessant and Alain Frisch)
+- PR#5880: 'Genlex.make_lexer' documention mentions the wrong exception
+ (Xavier Clerc, report by Virgile Prevosto)
+- PR#5885: Incorrect rule for compiling C stubs when shared libraries are not
+ supported.
+ (Jérôme Vouillon)
+- PR#5891: ocamlbuild: support rectypes tag for mlpack
+ (Khoo Yit Phang)
+- PR#5892: GADT exhaustiveness check is broken
+ (Jacques Garrigue and Leo P. White)
+- PR#5906: GADT exhaustiveness check is still broken
+ (Jacques Garrigue, report by Sébastien Briais)
+- PR#5907: Undetected cycle during typecheck causes exceptions
+ (Jacques Garrigue, report by Pascal Zimmer)
+- PR#5910: Fix code generation bug for "mod 1" on ARM.
+ (Benedikt Meurer, report by user 'jteg68')
+- PR#5911: Signature substitutions fail in submodules
+ (Jacques Garrigue, report by Markus Mottl)
+- PR#5912: add configure option -no-cfi (for OSX 10.6.x with XCode 4.0.2)
+ (Damien Doligez against XCode versions, report by Thomas Gazagnaire)
+- PR#5914: Functor breaks with an equivalent argument signature
+ (Jacques Garrigue, report by Markus Mottl and Grégoire Henry)
+- PR#5920, PR#5957: linking failure for big bytecodes on 32bit architectures
+ (Benoît Vaugon and Chet Murthy, report by Jun Furuse and Sebastien Mondet)
+- PR#5928: Missing space between words in manual page for ocamlmktop
+ (Damien Doligez, report by Matej Košík)
+- PR#5930: ocamldep leaks temporary preprocessing files
+ (Gabriel Scherer, report by Valentin Gatien-Baron)
+- PR#5933: Linking is slow when there are functions with large arities
+ (Valentin Gatien-Baron, review by Gabriel Scherer)
+- PR#5934: integer shift by negative amount (in otherlibs/num)
+ (Xavier Leroy, report by John Regehr)
+- PR#5944: Bad typing performances of big variant type declaration
+ (Benoît Vaugon)
+- PR#5945: Mix-up of Minor_heap_min and Minor_heap_max units
+ (Benoît Vaugon)
+- PR#5948: GADT with polymorphic variants bug
+ (Jacques Garrigue, report by Leo P. White)
+- PR#5953: Unix.system does not handle EINTR
+ (Jérémie Dimino)
+- PR#5965: disallow auto-reference to a recursive module in its definition
+ (Alain Frisch, report by Arthur Windler via Gabriel Scherer)
+- PR#5973: Format module incorrectly parses format string
+ (Pierre Weis, report by Frédéric Bour)
+- PR#5974: better documentation for Str.regexp
+ (Damien Doligez, report by william)
+- PR#5976: crash after recovering from two stack overflows (ocamlopt on MacOS X)
+ (Xavier Leroy, report by Pierre Boutillier)
+- PR#5977: Build failure on raspberry pi: "input_value: integer too large"
+ (Alain Frisch, report by Sylvain Le Gall)
+- PR#5981: Incompatibility check assumes abstracted types are injective
+ (Jacques Garrigue, report by Jeremy Yallop)
+- PR#5982: caml_leave_blocking section and errno corruption
+ (Jérémie Dimino)
+- PR#5985: Unexpected interaction between variance and GADTs
+ (Jacques Garrigue, Jeremy Yallop and Leo P. White and Gabriel Scherer)
+- PR#5988: missing from the documentation: -impl is a valid flag for ocamlopt
+ (Damien Doligez, report by Vincent Bernardoff)
+- PR#5989: Assumed inequalities involving private rows
+ (Jacques Garrigue, report by Jeremy Yallop)
+- PR#5992: Crash when pattern-matching lazy values modifies the scrutinee
+ (Luc Maranget, Leo P. White)
+- PR#5993: Variance of private type abbreviations not checked for modules
+ (Jacques Garrigue)
+- PR#5997: Non-compatibility assumed for concrete types with same constructor
+ (Jacques Garrigue, report by Gabriel Scherer)
+- PR#6004: Type information does not flow to "inherit" parameters
+ (Jacques Garrigue, report by Alain Frisch)
+- PR#6005: Type unsoundness with recursive modules
+ (Jacques Garrigue, report by Jérémie Dimino and Josh Berdine)
+- PR#6010: Big_int.extract_big_int gives wrong results on negative arguments
+ (Xavier Leroy, report by Drake Wilson via Stéphane Glondu)
+- PR#6024: Format syntax for printing @ is incompatible with 3.12.1
+ (Damien Doligez, report by Boris Yakobowski)
+- PR#6001: Reduce the memory used by compiling Camlp4
+ (Hongbo Zhang and Gabriel Scherer, report by Henri Gouraud)
+- PR#6031: Camomile problem with -with-frame-pointers
+ (Fabrice Le Fessant, report by Anil Madhavapeddy)
+- PR#6032: better Random.self_init under Windows
+ (Alain Frisch, Xavier Leroy)
+- PR#6033: Matching.inline_lazy_force needs eta-expansion (command-line flags)
+ (Pierre Chambart, Xavier Leroy and Luc Maranget,
+ regression report by Gabriel Scherer)
+- PR#6046: testsuite picks up the wrong ocamlrun dlls
+ (Anil Madhavapeddy)
+- PR#6056: Using 'match' prevents generalization of values
+ (Jacques Garrigue, report by Elnatan Reisner)
+- PR#6058: 'ocamlbuild -use-ocamlfind -tag thread -package threads t.cma' fails
+ (Gabriel Scherer, report by Hezekiah M. Carty)
+- PR#6060: ocamlbuild rules for -principal, -strict-sequence and -short-paths
+ (Anil Madhavapeddy)
+- PR#6069: ocamldoc: lexing: empty token
+ (Maxence Guesdon, Grégoire Henry, report by ygrek)
+- PR#6072: configure does not handle FreeBSD current (i.e. 10) correctly
+ (Damien Doligez, report by Prashanth Mundkur)
+- PR#6074: Wrong error message for failing Condition.broadcast
+ (Markus Mottl)
+- PR#6084: Define caml_modify and caml_initialize as weak symbols to help
+ with Netmulticore
+ (Xavier Leroy, Gerd Stolpmann)
+- PR#6090: Module constraint + private type seems broken in ocaml 4.01.0
+ (Jacques Garrigue, report by Jacques-Pascal Deplaix)
+- PR#6109: Typos in ocamlbuild error messages
+ (Gabriel Kerneis)
+- PR#6123: Assert failure when self escapes its class
+ (Jacques Garrigue, report by whitequark)
+- PR#6158: Fatal error using GADTs
+ (Jacques Garrigue, report by Jeremy Yallop)
+- PR#6163: Assert_failure using polymorphic variants in GADTs
+ (Jacques Garrigue, report by Leo P. White)
+- PR#6164: segmentation fault on Num.power_num of 0/1
+ (Fabrice Le Fessant, report by Johannes Kanig)
+
+Feature wishes:
+- PR#5181: Merge common floating point constants in ocamlopt
+ (Benedikt Meurer)
+- PR#5243: improve the ocamlbuild API documentation in signatures.mli
+ (Christophe Troestler)
+- PR#5546: moving a function into an internal module slows down its use
+ (Alain Frisch, report by Fabrice Le Fessant)
+- PR#5597: add instruction trace option 't' to OCAMLRUNPARAM
+ (Anil Madhavapeddy, Wojciech Meyer)
+- PR#5676: IPv6 support under Windows
+ (Jérôme Vouillon, review by Jonathan Protzenko)
+- PR#5721: configure -with-frame-pointers for Linux perf profiling
+ (Fabrice Le Fessant, test by Jérémie Dimino)
+- PR#5722: toplevel: print full module path only for first record field
+ (Jacques Garrigue, report by ygrek)
+- PR#5762: Add primitives for fast access to bigarray dimensions
+ (Pierre Chambart)
+- PR#5769: Allow propagation of Sys.big_endian in native code
+ (Pierre Chambart, stealth commit by Fabrice Le Fessant)
+- PR#5771: Add primitives for reading 2, 4, 8 bytes in strings and bigarrays
+ (Pierre Chambart)
+- PR#5774: Add bswap primitives for amd64 and arm
+ (Pierre Chambart, test by Alain Frisch)
+- PR#5795: Generate sqrtsd opcode instead of external call to sqrt on amd64
+ (Pierre Chambart)
+- PR#5827: provide a dynamic command line parsing mechanism
+ (Hongbo Zhang)
+- PR#5832: patch to improve "wrong file naming" error messages
+ (William Smith)
+- PR#5864: Add a find operation to Set
+ (François Berenger)
+- PR#5886: Small changes to compile for Android
+ (Jérôme Vouillon, review by Benedikt Meurer)
+- PR#5902: -ppx based pre-processor executables accept arguments
+ (Alain Frisch, report by Wojciech Meyer)
+- PR#5986: Protect against marshaling 64-bit integers in bytecode
+ (Xavier Leroy, report by Alain Frisch)
+- PR#6049: support for OpenBSD/macppc platform
+ (Anil Madhavapeddy, review by Benedikt Meurer)
+- PR#6059: add -output-obj rules for ocamlbuild
+ (Anil Madhavapeddy)
+
+Tools:
+- OCamlbuild now features a bin_annot tag to generate .cmt files.
+ (Jonathan Protzenko)
+- OCamlbuild now features a strict_sequence tag to trigger the
+ strict-sequence option.
+ (Jonathan Protzenko)
+- OCamlbuild now picks the non-core tools like ocamlfind and menhir from PATH
+ (Wojciech Meyer)
+- PR#5884: Misc minor fixes and cleanup for emacs mode
+ (Stefan Monnier)
+- PR#6030: Improve performance of -annot
+ (Guillaume Melquiond, Alain Frisch)
+
+
OCaml 4.00.1:
-------------
. More random initialization (Random.self_init()), using /dev/urandom
when available (e.g. Linux, FreeBSD, MacOS X, Solaris)
* Faster implementation of Random.float (changes the generated sequences)
+- Format strings for formatted input/output revised to correct PR#5380
+ . Consistently treat %@ as a plain @ character
+ . Consistently treat %% as a plain % character
+- Scanf: width and precision for floating point numbers are now handled
- Scanf: new function "unescaped" (PR#3888)
- Set and Map: more efficient implementation of "filter" and "partition"
- String: new function "map" (PR#3888)
* PR#5312: command-line arguments @reponsefile auto-expansion feature
removed from the Windows OCaml runtime, to avoid conflicts with "-w @..."
- PR#5313: ocamlopt -g misses optimizations
+- PR#5214: ocamlfind plugin invokes 'cut' utility
- PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable
- PR#5318: segfault on stack overflow when reading marshaled data
- PR#5319: %r11 clobbered by Lswitch in Windows AMD64 native-code compilation
- PR#5322: type abbreviations expanding to a universal type variable
-- PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in
- another thread
- PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode
- PR#5330: thread tag with '.top' and '.inferred.mli' targets
- PR#5331: ocamlmktop is not always a shell script
- PR#5335: Unix.environment segfaults after a call to clearenv
- PR#5338: sanitize.sh has windows style end-of-lines (mingw)
-- PR#5343: ocaml -rectypes is unsound wrt module subtyping
- PR#5344: some predefined exceptions need special printing
- PR#5349: Hashtbl.replace uses new key instead of reusing old key
- PR#5356: ocamlbuild handling of 'predicates' for ocamlfind
- PR#5018: wrong exception raised by Dynlink.loadfile.
- PR#5057: fatal typing error with local module + functor + polymorphic variant
- Wrong type for Obj.add_offset.
-- Small problem with the representation of Int32, Int64, and Nativeint constants.
+- Small problem with representation of Int32, Int64, and Nativeint constants.
- Use RTLD_LOCAL for native dynlink in private mode.
Objective Caml 3.11.2:
- Module Printf:
added %S and %C formats (quoted, escaped strings and characters);
added kprintf (calls user-specified continuation on formatted string).
-- Module Queue: faster implementation (courtesy of François Pottier).
+- Module Queue: faster implementation (courtesy of Francois Pottier).
- Module Random: added Random.bool.
- Module Stack: added Stack.is_empty.
- Module Pervasives:
performance. gcc is the standard compiler under Linux, MacOS X,
and many other systems.
-* Under MacOS X 10.5, you need version 3.1 or later of the XCode
- development tools. The version of XCode found on MacOS X 10.5
- installation media causes linking problems. XCode updates
- are available free of charge at http://developer.apple.com/tools/xcode/
-
-* Under MacOS X up to version 10.2.8, you must raise the limit on the
- stack size with one of the following commands:
-
- limit stacksize 64M # if your shell is zsh or tcsh
- ulimit -s 65536 # if your shell is bash
-
* If you do not have write access to /tmp, you should set the environment
variable TMPDIR to the name of some other temporary directory.
The linker and options to use for producing an object file
(rather than an executable) from several other object files.
+-no-cfi
+ Do not compile support for CFI directives.
+
Examples:
Standard installation in /usr/{bin,lib,man} instead of /usr/local:
or:
./configure -prefix /usr -mandir '$(PREFIX)/man/manl'
- On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host,
- to build a 64-bit version of OCaml:
- ./configure -cc "gcc -m64"
-
- On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml:
- ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c"
-
On a Linux x86/64 bits host, to build a 32-bit version of OCaml:
- ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c"
+ ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" \
+ -host i386-linux -partialld "ld -r -melf_i386"
On a Linux x86/64 bits host, to build the run-time system in PIC mode
(enables putting the runtime in a shared library,
at a small performance cost):
./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC"
+ On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host,
+ to build a 64-bit version of OCaml:
+ ./configure -cc "gcc -m64"
+
+ On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml:
+ ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c"
+
For Sun Solaris with the "acc" compiler:
./configure -cc "acc -fast" -libs "-lucb"
unable to compile correctly the runtime system (wrong code is
generated for (x - y) where x is a pointer and y an integer).
Fix: use gcc.
+
+* Under MacOS X 10.6, with XCode 4.0.2, the configure script mistakenly
+detects support for CFI directives in the assembler.
+Fix: give the "-no-cfi" option to configure.
# #
#########################################################################
-# $Id: Makefile 12929 2012-09-17 16:23:06Z doligez $
-
# The main Makefile
include config/Makefile
CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
-COMPFLAGS= -strict-sequence -warn-error A $(INCLUDES)
+COMPFLAGS=-strict-sequence -w +33..39 -warn-error A $(INCLUDES)
LINKFLAGS=
CAMLYACC=boot/ocamlyacc
PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/syntaxerr.cmo parsing/parser.cmo \
- parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
+ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
+ parsing/pprintast.cmo \
+ parsing/ast_mapper.cmo
TYPING=typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
typing/printtyp.cmo typing/includeclass.cmo \
- typing/mtype.cmo typing/includecore.cmo \
+ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
- typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \
+ typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \
+ typing/stypes.cmo typing/typecore.cmo \
typing/typedecl.cmo typing/typeclass.cmo \
typing/typemod.cmo
bytecomp/translobj.cmo bytecomp/translcore.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
- driver/pparse.cmo driver/main_args.cmo
+ driver/pparse.cmo driver/main_args.cmo \
+ driver/compenv.cmo driver/compmisc.cmo
COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
cd stdlib; $(MAKE) install
cp lex/ocamllex $(BINDIR)/ocamllex$(EXE)
cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE)
- cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR)
- cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR)
+ cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \
+ toplevel/*.cmi $(COMPLIBDIR)
+ cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \
+ $(COMPLIBDIR)
cp expunge $(LIBDIR)/expunge$(EXE)
cp toplevel/topdirs.cmi $(LIBDIR)
cd tools; $(MAKE) install
cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE)
cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE)
cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \
- compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \
- compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \
- $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \
- $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \
- $(COMPLIBDIR)
- cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a ocamloptcomp.a
+ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \
+ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \
+ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \
+ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \
+ $(COMPLIBDIR)
+ cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \
+ ocamloptcomp.a
clean:: partialclean
rm -f compilerlibs/ocamlbytecomp.cma
ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
- $(CAMLC) $(LINKFLAGS) -o ocamlc \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
+ $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \
+ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
@sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \
driver/ocamlcomp.sh.in > ocamlcomp.sh
@chmod +x ocamlcomp.sh
ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
$(CAMLC) $(LINKFLAGS) -o ocamlopt \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
+ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
@sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \
driver/ocamlcomp.sh.in > ocamlcompopt.sh
@chmod +x ocamlcompopt.sh
partialclean::
rm -f compilerlibs/ocamltoplevel.cma
-ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge
+ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge
$(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
+ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
- $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES)
rm -f ocaml.tmp
-e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
-e 's|%%ASM%%|$(ASM)|' \
-e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
+ -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \
-e 's|%%MKDLL%%|$(MKDLL)|' \
-e 's|%%MKEXE%%|$(MKEXE)|' \
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
partialclean::
rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a
-ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx)
+ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
+ $(BYTESTART:.cmo=.cmx)
$(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
- compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
- $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)"
+ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
+ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)"
@sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \
driver/ocamlcomp.sh.in > ocamlcomp.sh
@chmod +x ocamlcomp.sh
partialclean::
rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a
-ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx)
+ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+ $(OPTSTART:.cmo=.cmx)
$(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \
- compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
- $(OPTSTART:.cmo=.cmx)
+ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+ $(OPTSTART:.cmo=.cmx)
@sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \
driver/ocamlcomp.sh.in > ocamlcompopt.sh
@chmod +x ocamlcompopt.sh
# The "expunge" utility
-expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
- $(CAMLC) $(LINKFLAGS) -o expunge \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
+expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ toplevel/expunge.cmo
+ $(CAMLC) $(LINKFLAGS) -o expunge compilerlibs/ocamlcommon.cma \
+ compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
partialclean::
rm -f expunge
./build/camlp4-native-only.sh
# Ocamlbuild
-
+#ifeq ($(OCAMLBUILD_NOBOOT),"yes")
+#ocamlbuild.byte: ocamlc
+# $(MAKE) -C ocamlbuild -f Makefile.noboot
+#else
ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot
./build/ocamlbuild-byte-only.sh
+#endif
-ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot
+ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot otherlibrariesopt
./build/ocamlbuild-native-only.sh
-ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot
+ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot otherlibrariesopt
./build/ocamlbuildlib-native-only.sh
ocamlbuild-mixed-boot: ocamlc
distclean:
./build/distclean.sh
+ rm -f ocaml ocamlcomp.sh testsuite/_log
.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean
.PHONY: partialclean beforedepend alldepend cleanboot coldstart
# #
#########################################################################
-# $Id: Makefile.nt 12750 2012-07-20 08:06:01Z doligez $
-
# The main Makefile
include config/Makefile
PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/syntaxerr.cmo parsing/parser.cmo \
- parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
+ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
+ parsing/pprintast.cmo \
+ parsing/ast_mapper.cmo
TYPING=typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \
typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
- typing/typedtree.cmo typing/ctype.cmo \
+ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
typing/printtyp.cmo typing/includeclass.cmo \
- typing/mtype.cmo typing/includecore.cmo \
- typing/includemod.cmo typing/parmatch.cmo \
- typing/typetexp.cmo \
- typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \
+ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
+ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
+ typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \
+ typing/stypes.cmo typing/typecore.cmo \
typing/typedecl.cmo typing/typeclass.cmo \
typing/typemod.cmo
bytecomp/translobj.cmo bytecomp/translcore.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
- driver/pparse.cmo driver/main_args.cmo
+ driver/pparse.cmo driver/main_args.cmo \
+ driver/compenv.cmo driver/compmisc.cmo
COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
- asmcomp/clambda.cmo asmcomp/compilenv.cmo \
+ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
asmcomp/closure.cmo asmcomp/cmmgen.cmo \
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
asmcomp/comballoc.cmo asmcomp/liveness.cmo \
TOPLEVELSTART=toplevel/topstart.cmo
-PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree
+PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
# For users who don't read the INSTALL file
defaultentry:
cd stdlib ; $(MAKEREC) install
cp lex/ocamllex $(BINDIR)/ocamllex.exe
cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe
- cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR)
- cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR)
+ cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \
+ toplevel/*.cmi $(COMPLIBDIR)
+ cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \
+ $(COMPLIBDIR)
cp expunge $(LIBDIR)/expunge.exe
cp toplevel/topdirs.cmi $(LIBDIR)
cd tools ; $(MAKEREC) install
cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE)
cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE)
cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
- compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
- compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
- $(COMPLIBDIR)
+ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
+ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
+ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \
+ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \
+ $(COMPLIBDIR)
clean:: partialclean
rm -f compilerlibs/ocamlbytecomp.cma
ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
- $(CAMLC) $(LINKFLAGS) -o ocamlc \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
+ $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc compilerlibs/ocamlcommon.cma \
+ compilerlibs/ocamlbytecomp.cma $(BYTESTART)
@sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \
driver/ocamlcomp.sh.in > ocamlcomp.sh
@chmod +x ocamlcomp.sh
partialclean::
rm -f compilerlibs/ocamltoplevel.cma
-ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge
+ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge
$(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \
compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
# The native toplevel
ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
- $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall
+ $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \
+ $(NATTOPOBJS:.cmo=.cmx) -linkall
toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
-e "s|%%SYSTHREAD_SUPPORT%%|true|" \
-e 's|%%ASM%%|$(ASM)|' \
-e 's|%%ASM_CFI_SUPPORTED%%|false|' \
+ -e 's|%%WITH_FRAME_POINTERS%%|false|' \
-e 's|%%MKDLL%%|$(MKDLL)|' \
-e 's|%%MKEXE%%|$(MKEXE)|' \
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
partialclean::
rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A)
-ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx)
+ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
+ $(BYTESTART:.cmo=.cmx)
$(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
$(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)"
partialclean::
rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A)
-ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx)
+ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+ $(OPTSTART:.cmo=.cmx)
$(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \
compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
$(OPTSTART:.cmo=.cmx)
# The "expunge" utility
-expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
- $(CAMLC) $(LINKFLAGS) -o expunge \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
+expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ toplevel/expunge.cmo
+ $(CAMLC) $(LINKFLAGS) -o expunge compilerlibs/ocamlcommon.cma \
+ compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
partialclean::
rm -f expunge
partialclean::
rm -rf _build
+# Make clean in the test suite
+
+clean::
+ cd testsuite; $(MAKE) clean
+
# Default rules
.SUFFIXES: .ml .mli .cmo .cmi .cmx
configuration you are using (machine type, etc).
You can also contact the implementors directly at caml@inria.fr.
-
-
-----
-$Id: README 12149 2012-02-10 16:15:24Z doligez $
http://www.microsoft.com/downloads/en/default.aspx
under the name "Microsoft Windows 7 SDK".
-[2] flexdll version 0.29 or later.
+[2] flexdll version 0.31 or later.
Can be downloaded from http://alain.frisch.fr/flexdll.html
[3] TCL/TK version 8.5. Windows binaries are available as part of the
compiling on a 64-bit Windows.
- The Cygwin port of GNU tools, available from http://www.cygwin.com/
Install at least the following packages (and their dependencies):
- diffutils, make, ncurses.
+ diffutils, dos2unix, gcc-core, make, ncurses.
First, you need to set up your cygwin environment for using the MS
tools. The following assumes that you have installed [1], [2], and [3]
http://www.microsoft.com/downloads/en/default.aspx
under the name "Microsoft Windows 7 SDK".
-[2] flexdll version 0.29 or later.
+[2] flexdll version 0.31 or later.
Can be downloaded from http://alain.frisch.fr/flexdll.html
echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv
echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv
echo FLPATH="`cygpath '%PFPATH%\flexdll'`" >>C:\cygwin\tmp\msenv
- echo PATH="${VCPATH}:$PATH:${FLPATH}" >>C:\cygwin\tmp\msenv
+ echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv
echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv
echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv
+++ /dev/null
-
- FAQ: how to upgrade from Objective Caml 3.02 to 3.03
-
-I Installation
-
-Q1: When compiling the distribution, I am getting strange linking
- errors in "otherlibraries".
-
-A1: This is probably a problem with dynamic linking. You can disable
- it with ./configure -no-shared-libs. If you really want to use
- shared libraries, look in the manual pages of your system for how
- to get some debugging output from the dynamic linker.
-
-II Non-label changes
-
-Q2: I get a syntax error when I try to compile a program using stream
- parsers.
-
-A2: Stream parser now require camlp4. It is included in the
- distribution, and you just need to use "ocamlc -pp camlp4o" in
- place of "ocamlc". You can also use it under the toplevel with
- #load"camlp4o.cma".
-
-Q3: I get a warning when I use the syntax "#variant" inside type
- expressions.
-
-A3: The new syntax is [< variant], which just a special case of
- the more general new syntax, which allows type expressions like
- [ variant1 | variant2] or [> variant]. See the reference manual
- for details.
-
-III Label changes
-
-Q4: I was using labels before, and now I get lots of type errors.
-
-A4: The handling of labels changed with 3.03-alpha. The new default
- is a more flexible version of the commuting label mode, allowing
- one to omit labels in total applications. There is still a
- -nolabels mode, but it does not allow non-optional labels in
- applications (this was unsound).
- To keep full compatibility with Objective Caml 2, labels were
- removed from the standard libraries. Some labelized libraries are
- kept as StdLabels (contains Array, List and String), MoreLabels
- (contains Hashtbl, Map and Set), and UnixLabels.
- Note that MoreLabels' status is not yet decided.
-
-Q5: Why isn't there a ThreadUnixLabels module ?
-
-A5: ThreadUnix is deprecated. It only calls directly the Unix module.
-
-Q6: I was using commuting label mode, how can I upgrade ?
-
-A6: The new behaviour is compatible with commuting label mode, but
- standard libraries have no labels. You can add the following
- lines at the beginning of your files (according to your needs):
- open Stdlabels
- open MoreLabels
- module Unix = UnixLabels
- Alternatively, if you already have a common module opened by
- everybody, you can add these:
- include StdLabels
- include MoreLabels
- module Unix = UnixLabels
-
- You will then need to remove labels in functions from other modules.
- This can be automated by using the scrapelabels tool, installed
- in the Objective Caml library directory, which both removes labels
- and inserts needed `open' clauses (see -help for details).
- $CAMLLIB/scrapelabels -keepstd *.ml
- or
- $CAMLLIB/scrapelabels -keepmore *.ml
- Note that scrapelabels is not guaranteed to be sound for commuting
- label programs, since it will just remove labels, and not reorder
- arguments.
-
-Q7: I was using a few labels in classic mode, and now I get all these
- errors. I just want to get rid of all these silly labels.
-
-A7: scrapelabels will do it for you.
- $CAMLLIB/scrapelabels [-all] *.ml
- $CAMLLIB/scrapelabels -intf *.mli
- You should specify the -all option only if you are sure that your
- sources do not contain calls to functions with optional
- parameters, as those labels would also be removed.
-
-Q8: I was using labels in classic mode, and I was actually pretty fond
- of them. How much more labels will I have to write now ? How can I
- convert my programs and libraries ?
-
-A8: The new default mode is more flexible than the original commuting
- mode, so that you shouldn't see too much differences when using
- labeled libraries. Labels are only compulsory in partial
- applications (including the special case of function with an
- unknown return type), or if you wrote some of them.
-
- On the other hand, for definitions, labels present in the
- interface must also be present in the implementation.
- The addlabels tool can help you to do that. Suppose that you have
- mymod.ml and mymod.mli, where mymod.mli adds some labels. Then
- doing
- $CAMLLIB/addlabels mymod.ml
- will insert labels from the interface inside the implementation.
- It also takes care of inserting them in recursive calls, as
- the return type of the function is not known while typing it.
-
- If you used labels from standard libraries, you will also have
- problems with them. You can proceed as described in A6. Since you
- used classic mode, you do not need to bother about changed
- argument order.
-4.00.1
+4.01.0
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
-
-# $Id: VERSION 12983 2012-10-03 15:11:00Z doligez $
(* *)
(***********************************************************************)
-(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *)
-
(* Machine-specific command-line options *)
let pic_code = ref true
| Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
| Ifloatarithmem of float_operation * addressing_mode
(* Float arith operation with memory *)
+ | Ibswap of int (* endiannes conversion *)
+ | Isqrtf (* Float square root *)
+ | Ifloatsqrtf of addressing_mode (* Float square root from memory *)
and float_operation =
Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv
let size_int = 8
let size_float = 8
+let allow_unaligned_access = true
+
(* Behavior of division *)
let division_crashes_on_overflow = true
fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl
| Ioffset_loc(n, addr) ->
fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n
+ | Isqrtf ->
+ fprintf ppf "sqrtf %a" printreg arg.(0)
+ | Ifloatsqrtf addr ->
+ fprintf ppf "sqrtf float64[%a]"
+ (print_addressing printreg addr) [|arg.(0)|]
| Ifloatarithmem(op, addr) ->
let op_name = function
| Ifloatadd -> "+f"
fprintf ppf "%a %s float64[%a]" printreg arg.(0) (op_name op)
(print_addressing printreg addr)
(Array.sub arg 1 (Array.length arg - 1))
+ | Ibswap i ->
+ fprintf ppf "bswap_%i %a" i printreg arg.(0)
(* *)
(***********************************************************************)
-(* $Id: emit.mlp 12907 2012-09-08 16:51:03Z xleroy $ *)
-
(* Emission of x86-64 (AMD 64) assembly code *)
-open Misc
open Cmm
open Arch
open Proc
let macosx = (Config.system = "macosx")
let mingw64 = (Config.system = "mingw64")
+let fp = Config.with_frame_pointers
+
(* Tradeoff between code size and code speed *)
let fastcode_flag = ref true
(* Layout of the stack frame *)
let frame_required () =
- !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0
+ fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0
let frame_size () = (* includes return address *)
if frame_required() then begin
let sz =
- (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8)
+ (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8
+ + (if fp then 8 else 0) )
in Misc.align sz 16
end else
!stack_offset + 8
let reg_low_8_name =
[| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b";
- "%r12b"; "%r13b"; "%bpl"; "%r10b"; "%r11b" |]
+ "%r12b"; "%r13b"; "%r10b"; "%r11b"; "%bpl" |]
let reg_low_16_name =
[| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w";
- "%r12w"; "%r13w"; "%bp"; "%r10w"; "%r11w" |]
+ "%r12w"; "%r13w"; "%r10w"; "%r11w"; "%bp" |]
let reg_low_32_name =
[| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d";
- "%r12d"; "%r13d"; "%ebp"; "%r10d"; "%r11d" |]
+ "%r12d"; "%r13d"; "%r10d"; "%r11d"; "%ebp" |]
let emit_subreg tbl r =
match r.loc with
` jp {emit_label lbl}\n`; (* branch taken if unordered *)
` jne {emit_label lbl}\n` (* branch taken if x<y or x>y *)
| (Clt, _) ->
- ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *)
+ ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *)
if not neg then
` ja {emit_label lbl}\n` (* branch taken if y>x i.e. x<y *)
else
` jbe {emit_label lbl}\n` (* taken if unordered or y<=x i.e. !(x<y) *)
| (Cle, _) ->
- ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *)
+ ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *)
if not neg then
` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *)
else
` jb {emit_label lbl}\n` (* taken if unordered or y<x i.e. !(x<=y) *)
| (Cgt, _) ->
- ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`;
+ ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`;
if not neg then
` ja {emit_label lbl}\n` (* branch taken if x>y *)
else
` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *)
| (Cge, _) ->
- ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *)
+ ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *)
if not neg then
` jae {emit_label lbl}\n` (* branch taken if x>=y *)
else
let output_epilogue f =
if frame_required() then begin
- let n = frame_size() - 8 in
+ let n = frame_size() - 8 - (if fp then 8 else 0) in
` addq ${emit_int n}, %rsp\n`;
cfi_adjust_cfa_offset (-n);
+ if fp then begin
+ ` popq %rbp\n`
+ end;
f ();
(* reset CFA back cause function body may continue *)
cfi_adjust_cfa_offset n
else
f ()
+(* Floating-point constants *)
+
+let float_constants = ref ([] : (string * int) list)
+
+let add_float_constant cst =
+ try
+ List.assoc cst !float_constants
+ with
+ Not_found ->
+ let lbl = new_label() in
+ float_constants := (cst, lbl) :: !float_constants;
+ lbl
+
+let emit_float_constant (cst, lbl) =
+ `{emit_label lbl}:`;
+ emit_float64_directive ".quad" cst
+
(* Output the assembly code for an instruction *)
(* Name of current function *)
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0
-let float_constants = ref ([] : (int * string) list)
-
(* Emit an instruction *)
let emit_instr fallthrough i =
emit_debug_info i.dbg;
| 0x0000_0000_0000_0000L -> (* +0.0 *)
` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
| _ ->
- let lbl = new_label() in
- float_constants := (lbl, s) :: !float_constants;
+ let lbl = add_float_constant s in
` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
end
| Lop(Iconst_symbol s) ->
` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n`
| Lop(Ispecific(Ifloatarithmem(op, addr))) ->
` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n`
+ | Lop(Ispecific(Ibswap size)) ->
+ begin match size with
+ | 16 ->
+ ` xchg %ah, %al\n`;
+ ` movzwq {emit_reg16 i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | 32 ->
+ ` bswap {emit_reg32 i.res.(0)}\n`;
+ ` movslq {emit_reg32 i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | 64 ->
+ ` bswap {emit_reg i.res.(0)}\n`
+ | _ -> assert false
+ end
+ | Lop(Ispecific Isqrtf) ->
+ ` sqrtsd {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
+ | Lop(Ispecific(Ifloatsqrtf addr)) ->
+ ` sqrtsd {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
| Lreloadretaddr ->
()
| Lreturn ->
emit_instr fallthrough i;
emit_all (Linearize.has_fallthrough i.desc) i.next
-(* Emission of the floating-point constants *)
-
-let emit_float_constant (lbl, cst) =
- `{emit_label lbl}:`;
- emit_float64_directive ".quad" cst
-
(* Emission of the profiling prelude *)
let emit_profile () =
need to preserve other regs. We do need to initialize rbp
like mcount expects it, though. *)
` pushq %r10\n`;
- ` movq %rsp, %rbp\n`;
+ if not fp then
+ ` movq %rsp, %rbp\n`;
` {emit_call "mcount"}\n`;
` popq %r10\n`
| _ ->
fastcode_flag := fundecl.fun_fast;
tailrec_entry_point := new_label();
stack_offset := 0;
- float_constants := [];
call_gc_sites := [];
bound_error_sites := [];
bound_error_call := 0;
`{emit_symbol fundecl.fun_name}:\n`;
emit_debug_info fundecl.fun_dbg;
cfi_startproc ();
+ if fp then begin
+ ` pushq %rbp\n`;
+ cfi_adjust_cfa_offset 8;
+ ` movq %rsp, %rbp\n`;
+ end;
if !Clflags.gprofile then emit_profile();
if frame_required() then begin
- let n = frame_size() - 8 in
+ let n = frame_size() - 8 - (if fp then 8 else 0) in
` subq ${emit_int n}, %rsp\n`;
cfi_adjust_cfa_offset n;
end;
` .type {emit_symbol fundecl.fun_name},@function\n`;
` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n`
| _ -> ()
- end;
- if !float_constants <> [] then begin
- if macosx then
- ` .literal8\n`
- else if mingw64 then
- ` .section .rdata,\"dr\"\n`
- else
- ` .section .rodata.cst8,\"a\",@progbits\n`;
- List.iter emit_float_constant !float_constants
end
(* Emission of data *)
let begin_assembly() =
reset_debug_info(); (* PR#5603 *)
+ float_constants := [];
if !Clflags.dlcode then begin
(* from amd64.S; could emit these constants on demand *)
if macosx then
if macosx then ` nop\n` (* PR#4690 *)
let end_assembly() =
+ if !float_constants <> [] then begin
+ if macosx then
+ ` .literal8\n`
+ else if mingw64 then
+ ` .section .rdata,\"dr\"\n`
+ else
+ ` .section .rodata.cst8,\"a\",@progbits\n`;
+ List.iter emit_float_constant !float_constants
+ end;
let lbl_end = Compilenv.make_symbol (Some "code_end") in
` .text\n`;
if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *)
(* *)
(***********************************************************************)
-(* $Id: emit_nt.mlp 12907 2012-09-08 16:51:03Z xleroy $ *)
-
(* Emission of x86-64 (AMD 64) assembly code, MASM syntax *)
module StringSet =
- Set.Make(struct type t = string let compare = compare end)
+ Set.Make(struct type t = string let compare (x:t) y = compare x y end)
open Misc
open Cmm
let reg_low_8_name =
[| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b";
- "r12b"; "r13b"; "bpl"; "r10b"; "r11b" |]
+ "r12b"; "r13b"; "r10b"; "r11b"; "bpl" |]
let reg_low_16_name =
[| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w";
- "r12w"; "r13w"; "bp"; "r10w"; "r11w" |]
+ "r12w"; "r13w"; "r10w"; "r11w"; "bp" |]
let reg_low_32_name =
[| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d";
- "r12d"; "r13d"; "ebp"; "r10d"; "r11d" |]
+ "r12d"; "r13d"; "r10d"; "r11d"; "ebp" |]
let emit_subreg tbl pref r =
match r.loc with
` add rsp, {emit_int n}\n`
end
+(* Floating-point constants *)
+
+let float_constants = ref ([] : (string * int) list)
+
+let add_float_constant cst =
+ try
+ List.assoc cst !float_constants
+ with
+ Not_found ->
+ let lbl = new_label() in
+ float_constants := (cst, lbl) :: !float_constants;
+ lbl
+
+let emit_float s =
+ (* MASM doesn't like floating-point constants such as 2e9.
+ Turn them into 2.0e9. *)
+ let pos_e = ref (-1) and pos_dot = ref (-1) in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ 'e'|'E' -> pos_e := i
+ | '.' -> pos_dot := i
+ | _ -> ()
+ done;
+ if !pos_dot < 0 && !pos_e >= 0 then begin
+ emit_string (String.sub s 0 !pos_e);
+ emit_string ".0";
+ emit_string (String.sub s !pos_e (String.length s - !pos_e))
+ end else
+ emit_string s
+
+let emit_float_constant (cst, lbl) =
+ `{emit_label lbl} REAL8 {emit_float cst}\n`
+
(* Output the assembly code for an instruction *)
(* Name of current function *)
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0
-let float_constants = ref ([] : (int * string) list)
-
let emit_instr fallthrough i =
match i.desc with
Lend -> ()
| 0x0000_0000_0000_0000L -> (* +0.0 *)
` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
| _ ->
- let lbl = new_label() in
- float_constants := (lbl, s) :: !float_constants;
+ let lbl = add_float_constant s in
` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n`
end
| Lop(Iconst_symbol s) ->
` add QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n`
| Lop(Ispecific(Ifloatarithmem(op, addr))) ->
` {emit_string(instr_for_floatarithmem op)} {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n`
+ | Lop(Ispecific(Ibswap size)) ->
+ begin match size with
+ | 16 ->
+ ` xchg ah, al\n`;
+ ` movzx {emit_reg i.res.(0)}, {emit_reg16 i.res.(0)}\n`
+ | 32 ->
+ ` bswap {emit_reg32 i.res.(0)}\n`;
+ ` movsxd {emit_reg i.res.(0)}, {emit_reg32 i.res.(0)}\n`
+ | 64 ->
+ ` bswap {emit_reg i.res.(0)}\n`
+ | _ -> assert false
+ end
+ | Lop(Ispecific Isqrtf) ->
+ ` sqrtsd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+ | Lop(Ispecific(Ifloatsqrtf addr)) ->
+ ` sqrtsd {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 0}\n`
| Lreloadretaddr ->
()
| Lreturn ->
emit_instr fallthrough i;
emit_all (Linearize.has_fallthrough i.desc) i.next
-(* Emission of the floating-point constants *)
-
-let emit_float s =
- (* MASM doesn't like floating-point constants such as 2e9.
- Turn them into 2.0e9. *)
- let pos_e = ref (-1) and pos_dot = ref (-1) in
- for i = 0 to String.length s - 1 do
- match s.[i] with
- 'e'|'E' -> pos_e := i
- | '.' -> pos_dot := i
- | _ -> ()
- done;
- if !pos_dot < 0 && !pos_e >= 0 then begin
- emit_string (String.sub s 0 !pos_e);
- emit_string ".0";
- emit_string (String.sub s !pos_e (String.length s - !pos_e))
- end else
- emit_string s
-
-let emit_float_constant (lbl, cst) =
- `{emit_label lbl} REAL8 {emit_float cst}\n`
-
(* Emission of a function declaration *)
let fundecl fundecl =
fastcode_flag := fundecl.fun_fast;
tailrec_entry_point := new_label();
stack_offset := 0;
- float_constants := [];
call_gc_sites := [];
bound_error_sites := [];
bound_error_call := 0;
`{emit_label !tailrec_entry_point}:\n`;
emit_all true fundecl.fun_body;
List.iter emit_call_gc !call_gc_sites;
- emit_call_bound_errors();
- if !float_constants <> [] then begin
- ` .DATA\n`;
- List.iter emit_float_constant !float_constants
- end
+ emit_call_bound_errors()
(* Emission of data *)
(* Beginning / end of an assembly file *)
let begin_assembly() =
+ float_constants := [];
` EXTRN caml_young_ptr: QWORD\n`;
` EXTRN caml_young_limit: QWORD\n`;
` EXTRN caml_exception_pointer: QWORD\n`;
`{emit_symbol lbl_begin} LABEL QWORD\n`
let end_assembly() =
+ if !float_constants <> [] then begin
+ ` .DATA\n`;
+ List.iter emit_float_constant !float_constants
+ end;
let lbl_end = Compilenv.make_symbol (Some "code_end") in
add_def_symbol lbl_end;
` .CODE\n`;
(* *)
(***********************************************************************)
-(* $Id: proc.ml 12907 2012-09-08 16:51:03Z xleroy $ *)
-
(* Description of the AMD64 processor *)
open Misc
open Reg
open Mach
+let fp = Config.with_frame_pointers
+
(* Which ABI to use *)
let win64 =
r9 7
r12 8
r13 9
- rbp 10
- r10 11
- r11 12
+ r10 10
+ r11 11
+ rbp 12
r14 trap pointer
r15 allocation pointer
match Config.ccomp_type with
| "msvc" ->
[| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
- "r12"; "r13"; "rbp"; "r10"; "r11" |]
+ "r12"; "r13"; "r10"; "r11"; "rbp" |]
| _ ->
[| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
- "%r12"; "%r13"; "%rbp"; "%r10"; "%r11" |]
+ "%r12"; "%r13"; "%r10"; "%r11"; "%rbp" |]
let float_reg_name =
match Config.ccomp_type with
let rax = phys_reg 0
let rcx = phys_reg 5
let rdx = phys_reg 4
+let rbp = phys_reg 12
let rxmm15 = phys_reg 115
let stack_slot slot ty =
if win64 then
(* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
Array.of_list(List.map phys_reg
- [0;4;5;6;7;11;12;
+ [0;4;5;6;7;10;11;
100;101;102;103;104;105])
else
(* Unix: rbp, rbx, r12-r15 preserved *)
Array.of_list(List.map phys_reg
- [0;2;3;4;5;6;7;11;12;
+ [0;2;3;4;5;6;7;10;11;
100;101;102;103;104;105;106;107;
108;109;110;111;112;113;114;115])
| Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _))
-> [| rax |]
| Iswitch(_, _) -> [| rax; rdx |]
- | _ -> [||]
+ | _ ->
+ if fp then
+(* prevent any use of the frame pointer ! *)
+ [| rbp |]
+ else
+ [||]
+
let destroyed_at_raise = all_phys_regs
(* Maximal register pressure *)
+
let safe_register_pressure = function
- Iextcall(_,_) -> if win64 then 8 else 0
- | _ -> 11
+ Iextcall(_,_) -> if win64 then if fp then 7 else 8 else 0
+ | _ -> if fp then 10 else 11
let max_register_pressure = function
- Iextcall(_, _) -> if win64 then [| 8; 10 |] else [| 4; 0 |]
- | Iintop(Idiv | Imod) -> [| 11; 16 |]
- | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)
- -> [| 12; 16 |]
- | Istore(Single, _) -> [| 13; 15 |]
- | _ -> [| 13; 16 |]
+ Iextcall(_, _) ->
+ if win64 then
+ if fp then [| 7; 10 |] else [| 8; 10 |]
+ else
+ if fp then [| 3; 0 |] else [| 4; 0 |]
+ | Iintop(Idiv | Imod) ->
+ if fp then [| 10; 16 |] else [| 11; 16 |]
+ | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) ->
+ if fp then [| 11; 16 |] else [| 12; 16 |]
+ | Istore(Single, _) ->
+ if fp then [| 12; 15 |] else [| 13; 15 |]
+ | _ -> if fp then [| 12; 16 |] else [| 13; 16 |]
(* Layout of the stack frame *)
else
Ccomp.command (Config.asm ^ " -o " ^
Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+let init () =
+ if fp then begin
+ num_available_registers.(0) <- 12
+ end else
+ num_available_registers.(0) <- 13
(* *)
(***********************************************************************)
-(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Cmm
open Arch
open Reg
(* *)
(***********************************************************************)
-(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-open Schedgen (* to create a dependency *)
+let _ = let module M = Schedgen in () (* to create a dependency *)
(* Scheduling is turned off because the processor schedules dynamically
much better than what we could do. *)
(* *)
(***********************************************************************)
-(* $Id: selection.ml 12122 2012-02-04 10:00:09Z bmeurer $ *)
-
(* Instruction selection for the AMD64 *)
-open Misc
open Arch
open Proc
open Cmm
-open Reg
open Mach
(* Auxiliary for recognizing addressing modes *)
([|res.(0); arg.(1)|], res)
(* One-address unary operations: arg.(0) and res.(0) must be the same *)
| Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _)
- | Iabsf | Inegf ->
+ | Iabsf | Inegf
+ | Ispecific(Ibswap (32|64)) ->
(res, res)
+ (* For xchg, args must be a register allowing access to high 8 bit register
+ (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *)
+ | Ispecific(Ibswap 16) ->
+ ([| rax |], [| rax |])
| Ispecific(Ifloatarithmem(_,_)) ->
let arg' = Array.copy arg in
arg'.(0) <- res.(0);
(* Other instructions are regular *)
| _ -> raise Use_default
+let inline_ops =
+ [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
+ "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
+
(* The selector class *)
class selector = object (self)
method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
+method! is_simple_expr e =
+ match e with
+ | Cop(Cextcall(fn, _, _, _), args)
+ when List.mem fn inline_ops ->
+ (* inlined ops are simple if their arguments are *)
+ List.for_all self#is_simple_expr args
+ | _ ->
+ super#is_simple_expr e
+
method select_addressing chunk exp =
let (a, d) = select_addr exp in
(* PR#4625: displacement must be a signed 32-bit immediate *)
self#select_floatarith true Imulf Ifloatmul args
| Cdivf ->
self#select_floatarith false Idivf Ifloatdiv args
+ | Cextcall("sqrt", _, false, _) ->
+ begin match args with
+ [Cop(Cload (Double|Double_u as chunk), [loc])] ->
+ let (addr, arg) = self#select_addressing chunk loc in
+ (Ispecific(Ifloatsqrtf addr), [arg])
+ | [arg] ->
+ (Ispecific Isqrtf, [arg])
+ | _ ->
+ assert false
+ end
(* Recognize store instructions *)
| Cstore Word ->
begin match args with
| _ ->
super#select_operation op args
end
+ | Cextcall("caml_bswap16_direct", _, _, _) ->
+ (Ispecific (Ibswap 16), args)
+ | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+ (Ispecific (Ibswap 32), args)
+ | Cextcall("caml_int64_direct_bswap", _, _, _)
+ | Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
+ (Ispecific (Ibswap 64), args)
| _ -> super#select_operation op args
(* Recognize float arithmetic with mem *)
(* *)
(***********************************************************************)
-(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *)
-
(* Specific operations for the ARM processor *)
-open Misc
open Format
-type abi = EABI | EABI_VFP
+type abi = EABI | EABI_HF
type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7
-type fpu = Soft | VFPv3_D16 | VFPv3
+type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3
let abi =
match Config.system with
"linux_eabi" -> EABI
- | "linux_eabihf" -> EABI_VFP
+ | "linux_eabihf" -> EABI_HF
| _ -> assert false
let string_of_arch = function
let string_of_fpu = function
Soft -> "soft"
+ | VFPv2 -> "vfpv2"
| VFPv3_D16 -> "vfpv3-d16"
| VFPv3 -> "vfpv3"
let (def_arch, def_fpu, def_thumb) =
begin match abi, Config.model with
(* Defaults for architecture, FPU and Thumb *)
- EABI, "armv5" -> ARMv5, Soft, false
- | EABI, "armv5te" -> ARMv5TE, Soft, false
- | EABI, "armv6" -> ARMv6, Soft, false
- | EABI, "armv6t2" -> ARMv6T2, Soft, false
- | EABI, "armv7" -> ARMv7, Soft, false
- | EABI, _ -> ARMv4, Soft, false
- | EABI_VFP, _ -> ARMv7, VFPv3_D16, true
+ EABI, "armv5" -> ARMv5, Soft, false
+ | EABI, "armv5te" -> ARMv5TE, Soft, false
+ | EABI, "armv6" -> ARMv6, Soft, false
+ | EABI, "armv6t2" -> ARMv6T2, Soft, false
+ | EABI, "armv7" -> ARMv7, Soft, false
+ | EABI, _ -> ARMv4, Soft, false
+ | EABI_HF, "armv6" -> ARMv6, VFPv2, false
+ | EABI_HF, _ -> ARMv7, VFPv3_D16, true
end in
(ref def_arch, ref def_fpu, ref def_thumb)
let farch spec =
arch := (match spec with
- "armv4" when abi <> EABI_VFP -> ARMv4
- | "armv5" when abi <> EABI_VFP -> ARMv5
- | "armv5te" when abi <> EABI_VFP -> ARMv5TE
- | "armv6" when abi <> EABI_VFP -> ARMv6
- | "armv6t2" when abi <> EABI_VFP -> ARMv6T2
- | "armv7" -> ARMv7
+ "armv4" when abi <> EABI_HF -> ARMv4
+ | "armv5" when abi <> EABI_HF -> ARMv5
+ | "armv5te" when abi <> EABI_HF -> ARMv5TE
+ | "armv6" -> ARMv6
+ | "armv6t2" -> ARMv6T2
+ | "armv7" -> ARMv7
| spec -> raise (Arg.Bad spec))
let ffpu spec =
fpu := (match spec with
- "soft" when abi <> EABI_VFP -> Soft
- | "vfpv3-d16" when abi = EABI_VFP -> VFPv3_D16
- | "vfpv3" when abi = EABI_VFP -> VFPv3
+ "soft" when abi <> EABI_HF -> Soft
+ | "vfpv2" when abi = EABI_HF -> VFPv2
+ | "vfpv3-d16" when abi = EABI_HF -> VFPv3_D16
+ | "vfpv3" when abi = EABI_HF -> VFPv3
| spec -> raise (Arg.Bad spec))
let command_line_options =
Ishiftarith of arith_operation * int
| Ishiftcheckbound of int
| Irevsubimm of int
- | Imuladd (* multiply and add *)
- | Imulsub (* multiply and subtract *)
- | Inegmulf (* floating-point negate and multiply *)
- | Imuladdf (* floating-point multiply and add *)
- | Inegmuladdf (* floating-point negate, multiply and add *)
- | Imulsubf (* floating-point multiply and subtract *)
- | Inegmulsubf (* floating-point negate, multiply and subtract *)
- | Isqrtf (* floating-point square root *)
+ | Imuladd (* multiply and add *)
+ | Imulsub (* multiply and subtract *)
+ | Inegmulf (* floating-point negate and multiply *)
+ | Imuladdf (* floating-point multiply and add *)
+ | Inegmuladdf (* floating-point negate, multiply and add *)
+ | Imulsubf (* floating-point multiply and subtract *)
+ | Inegmulsubf (* floating-point negate, multiply and subtract *)
+ | Isqrtf (* floating-point square root *)
+ | Ibswap of int (* endianess conversion *)
and arith_operation =
Ishiftadd
let size_int = 4
let size_float = 8
+let allow_unaligned_access = false
+
(* Behavior of division *)
let division_crashes_on_overflow = false
| Isqrtf ->
fprintf ppf "sqrtf %a"
printreg arg.(0)
+ | Ibswap n ->
+ fprintf ppf "bswap%i %a" n
+ printreg arg.(0)
(* Recognize immediate operands *)
(* *)
(***********************************************************************)
-(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Emission of ARM assembly code *)
-open Location
open Misc
open Cmm
open Arch
` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`;
2
end
+ | Lop(Iconst_float f) when !fpu = VFPv2 ->
+ let lbl = float_literal f in
+ ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`;
+ 1
| Lop(Iconst_float f) ->
let encode imm =
let sg = Int64.to_int (Int64.shift_right_logical imm 63) in
let ninstr = emit_stack_adjustment (-n) in
stack_offset := !stack_offset + n;
ninstr
- | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 ->
+ | Lop(Iload(Single, addr)) when !fpu >= VFPv2 ->
` flds s14, {emit_addressing addr i.arg 0}\n`;
` fcvtds {emit_reg i.res.(0)}, s14\n`; 2
| Lop(Iload((Double | Double_u), addr)) when !fpu = Soft ->
| Double_u -> "fldd"
| _ (* 32-bit quantities *) -> "ldr" in
` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1
- | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 ->
+ | Lop(Istore(Single, addr)) when !fpu >= VFPv2 ->
` fcvtsd s14, {emit_reg i.arg.(0)}\n`;
` fsts s14, {emit_addressing addr i.arg 1}\n`; 2
| Lop(Istore((Double | Double_u), addr)) when !fpu = Soft ->
| Imulsub -> "mls"
| _ -> assert false) in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1
+ | Lop(Ispecific(Ibswap size)) ->
+ begin match size with
+ 16 ->
+ ` rev16 {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`;
+ ` movt {emit_reg i.res.(0)}, #0\n`; 2
+ | 32 ->
+ ` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
+ | _ ->
+ assert false
+ end
| Lreloadretaddr ->
let n = frame_size() in
` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1
let n = emit_instr i in
let ninstr' = ninstr + n in
(* fldd can address up to +/-1KB, ldr can address up to +/-4KB *)
- let limit = (if !fpu >= VFPv3_D16 && !float_literals <> []
+ let limit = (if !fpu >= VFPv2 && !float_literals <> []
then 127
else 511) in
let limit = limit - !num_literals in
end;
begin match !fpu with
Soft -> ` .fpu softvfp\n`
+ | VFPv2 -> ` .fpu vfpv2\n`
| VFPv3_D16 -> ` .fpu vfpv3-d16\n`
| VFPv3 -> ` .fpu vfpv3\n`
end;
(* *)
(***********************************************************************)
-(* $Id: proc.ml 12125 2012-02-05 08:47:16Z bmeurer $ *)
-
(* Description of the ARM processor *)
open Misc
r13 stack pointer
r14 return address
r15 program counter
- Floatinng-point register map (VFPv3):
+ Floating-point register map (VFPv{2,3}):
d0 - d7 general purpose (not preserved)
d8 - d15 general purpose (preserved)
d16 - d31 generat purpose (not preserved), VFPv3 only
(* We have three register classes:
0 for integer registers
- 1 for VFPv3-D16
+ 1 for VFPv2 and VFPv3-D16
2 for VFPv3
- This way we can choose between VFPv3-D16 and VFPv3
+ This way we can choose between VFPv2/VFPv3-D16 and VFPv3
at (ocamlopt) runtime using command line switches.
*)
let register_class r =
match (r.typ, !fpu) with
(Int | Addr), _ -> 0
+ | Float, VFPv2 -> 1
| Float, VFPv3_D16 -> 1
| Float, _ -> 2
ofs := !ofs + size_int
end
| Float ->
- assert (abi = EABI_VFP);
- assert (!fpu >= VFPv3_D16);
+ assert (abi = EABI_HF);
+ assert (!fpu >= VFPv2);
if !float <= last_float then begin
loc.(i) <- phys_reg !float;
incr float
108;109;110;111;112;113;114;115;
116;116;118;119;120;121;122;123;
124;125;126;127;128;129;130;131]
- | EABI_VFP -> (* r4-r7, d8-d15 preserved *)
+ | EABI_HF -> (* r4-r7, d8-d15 preserved *)
[0;1;2;3;8;
100;101;102;103;104;105;106;107;
116;116;118;119;120;121;122;123;
124;125;126;127;128;129;130;131]))
let destroyed_at_oper = function
- Iop(Icall_ind | Icall_imm _ )
+ Iop(Icall_ind | Icall_imm _)
| Iop(Iextcall(_, true)) ->
all_phys_regs
| Iop(Iextcall(_, false)) ->
destroyed_at_c_call
- | Iop(Ialloc n) ->
+ | Iop(Ialloc _) ->
destroyed_at_alloc
| Iop(Iconst_symbol _) when !pic_code ->
- [|phys_reg 3; phys_reg 8|] (* r3 and r12 destroyed *)
+ [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *)
| Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) ->
- [|phys_reg 107|] (* d7 (s14-s15) destroyed *)
+ [| phys_reg 107 |] (* d7 (s14-s15) destroyed *)
| _ -> [||]
let destroyed_at_raise = all_phys_regs
(* Maximal register pressure *)
let safe_register_pressure = function
- Iextcall(_, _) -> 5
+ Iextcall(_, _) -> if abi = EABI then 0 else 4
+ | Ialloc _ -> if abi = EABI then 0 else 7
+ | Iconst_symbol _ when !pic_code -> 7
| _ -> 9
let max_register_pressure = function
- Iextcall(_, _) -> [| 5; 9; 9 |]
+ Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |]
+ | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |]
+ | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |]
+ | Iintoffloat | Ifloatofint
+ | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |]
| _ -> [| 9; 16; 32 |]
(* Layout of the stack *)
let assemble_file infile outfile =
Ccomp.command (Config.asm ^ " -o " ^
Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+
+let init () = ()
(* *)
(***********************************************************************)
-(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Reloading for the ARM *)
let fundecl f =
(* *)
(***********************************************************************)
-(* $Id: scheduling.ml 12125 2012-02-05 08:47:16Z bmeurer $ *)
-
open Arch
open Mach
| Imulf | Ispecific Inegmulf
| Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)
| Ispecific Isqrtf
- | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2
+ | Inegf | Iabsf when !fpu >= VFPv2 -> 2
(* Everything else *)
| _ -> 1
| Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17
| Idivf
| Ispecific Isqrtf -> 27
- | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4
+ | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv2 -> 4
(* Everything else *)
| _ -> 1
(* *)
(***********************************************************************)
-(* $Id: selection.ml 12125 2012-02-05 08:47:16Z bmeurer $ *)
-
(* Instruction selection for the ARM processor *)
open Arch
+open Proc
open Cmm
open Mach
-open Misc
-open Proc
-open Reg
let is_offset chunk n =
match chunk with
- (* VFPv3 load/store have -1020 to 1020 *)
+ (* VFPv{2,3} load/store have -1020 to 1020 *)
Single | Double | Double_u
- when !fpu >= VFPv3_D16 ->
+ when !fpu >= VFPv2 ->
n >= -1020 && n <= 1020
(* ARM load/store byte/word have -4095 to 4095 *)
| Byte_unsigned | Byte_signed
(* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *)
| Iabsf | Inegf when !fpu = Soft ->
([|res.(0); arg.(1)|], res)
- (* VFPv3 Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *)
+ (* VFPv{2,3} Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *)
| Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) ->
let arg' = Array.copy arg in
arg'.(0) <- res.(0);
method! is_simple_expr = function
(* inlined floating-point ops are simple if their arguments are *)
- | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 ->
+ | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv2 ->
+ List.for_all self#is_simple_expr args
+ (* inlined byte-swap ops are simple if their arguments are *)
+ | Cop(Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 ->
+ List.for_all self#is_simple_expr args
+ | Cop(Cextcall("caml_int32_direct_bswap", _,_,_), args) when !arch >= ARMv6 ->
List.for_all self#is_simple_expr args
| e -> super#is_simple_expr e
| (Cdivi, args) ->
(Iextcall("__aeabi_idiv", false), args)
| (Cmodi, [arg; Cconst_int n])
- when n = 1 lsl Misc.log2 n ->
+ when n > 1 && n = 1 lsl Misc.log2 n ->
(Iintop_imm(Imod, n), [arg])
| (Cmodi, args) ->
(* See above for fix up of return register *)
(Iextcall("__aeabi_idivmod", false), args)
+ (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *)
+ | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 ->
+ (Ispecific(Ibswap 16), args)
+ (* Recognize 32-bit bswap instructions (ARMv6 and above) *)
+ | (Cextcall("caml_int32_direct_bswap", _, _, _), args) when !arch >= ARMv6 ->
+ (Ispecific(Ibswap 32), args)
(* Turn floating-point operations into runtime ABI calls for softfp *)
| (op, args) when !fpu = Soft -> self#select_operation_softfp op args
- (* Select operations for VFPv3 *)
+ (* Select operations for VFPv{2,3} *)
| (op, args) -> self#select_operation_vfpv3 op args
method private select_operation_softfp op args =
(* *)
(***********************************************************************)
-(* $Id: asmgen.ml 12202 2012-03-07 17:50:17Z frisch $ *)
-
(* From lambda to assembly code *)
open Format
if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
phrase
+let clambda_dump_if ppf ulambda =
+ if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda
+
let rec regalloc ppf round fd =
if round > 50 then
fatal_error(fd.Mach.fun_name ^
let (++) x f = f x
let compile_fundecl (ppf : formatter) fd_cmm =
+ Proc.init ();
Reg.reset();
fd_cmm
++ Selection.fundecl
Emitaux.output_channel := oc;
Emit.begin_assembly();
Closure.intro size lam
+ ++ clambda_dump_if ppf
++ Cmmgen.compunit size
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ppf f);
(* *)
(***********************************************************************)
-(* $Id: asmgen.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* From lambda to assembly code *)
val compile_implementation :
(* *)
(***********************************************************************)
-(* $Id: asmlibrarian.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Build libraries of .cmx files *)
open Misc
let infos =
{ lib_units = descr_list;
lib_ccobjs = !Clflags.ccobjs;
- lib_ccopts = !Clflags.ccopts } in
+ lib_ccopts = !Clflags.all_ccopts } in
output_value outchan infos;
if Ccomp.create_archive archive_name objfile_list <> 0
then raise(Error(Archiver_error archive_name));
(* *)
(***********************************************************************)
-(* $Id: asmlibrarian.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Build libraries of .cmx files *)
open Format
(* *)
(***********************************************************************)
-(* $Id: asmlink.ml 12201 2012-03-07 17:40:17Z frisch $ *)
-
(* Link a set of .cmx/.o files and produce an executable *)
-open Sys
open Misc
open Config
open Cmx_format
(fun (info, file_name, crc) -> check_consistency file_name info crc)
units_tolink;
Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
- Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts;
+ Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
let objfiles = List.rev (List.map object_file_name objfiles) @
(List.rev !Clflags.ccobjs) in
(fun (info, file_name, crc) -> check_consistency file_name info crc)
units_tolink;
Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
- Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *)
+ Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
+ (* put user's opts first *)
let startup =
if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
(* *)
(***********************************************************************)
-(* $Id: asmlink.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Link a set of .cmx/.o files and produce an executable or a plugin *)
open Format
(* *)
(***********************************************************************)
-(* $Id: asmpackager.ml 12202 2012-03-07 17:50:17Z frisch $ *)
-
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
-open Printf
open Misc
-open Lambda
-open Clambda
open Cmx_format
type error =
- Illegal_renaming of string * string
+ Illegal_renaming of string * string * string
| Forward_reference of string * string
| Wrong_for_pack of string * string
| Linking_error
pm_name: string;
pm_kind: pack_member_kind }
-let read_member_info pack_path file =
+let read_member_info pack_path file = (
let name =
String.capitalize(Filename.basename(chop_extensions file)) in
let kind =
if Filename.check_suffix file ".cmx" then begin
let (info, crc) = Compilenv.read_unit_info file in
if info.ui_name <> name
- then raise(Error(Illegal_renaming(file, info.ui_name)));
+ then raise(Error(Illegal_renaming(name, file, info.ui_name)));
if info.ui_symbol <>
(Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name
then raise(Error(Wrong_for_pack(file, pack_path)));
end else
PM_intf in
{ pm_file = file; pm_name = name; pm_kind = kind }
+)
(* Check absence of forward references *)
open Format
let report_error ppf = function
- Illegal_renaming(file, id) ->
- fprintf ppf "Wrong file naming: %a@ contains the code for@ %s"
- Location.print_filename file id
+ Illegal_renaming(name, file, id) ->
+ fprintf ppf "Wrong file naming: %a@ contains the code for\
+ @ %s when %s was expected"
+ Location.print_filename file name id
| Forward_reference(file, ident) ->
fprintf ppf "Forward reference to %s in file %a" ident
Location.print_filename file
(* *)
(***********************************************************************)
-(* $Id: asmpackager.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
val package_files: Format.formatter -> string list -> string -> unit
type error =
- Illegal_renaming of string * string
+ Illegal_renaming of string * string * string
| Forward_reference of string * string
| Wrong_for_pack of string * string
| Linking_error
(* *)
(***********************************************************************)
-(* $Id: clambda.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* A variant of the "lambda" code with direct / indirect calls explicit
and closures explicit too *)
(* *)
(***********************************************************************)
-(* $Id: clambda.mli 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* A variant of the "lambda" code with direct / indirect calls explicit
and closures explicit too *)
(* *)
(***********************************************************************)
-(* $Id: closure.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Introduction of closures, uncurrying, recognition of direct calls *)
open Misc
let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n)
let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n)
let make_const_bool b = make_const_ptr(if b then 1 else 0)
+let make_comparison cmp (x: int) (y: int) =
+ make_const_bool
+ (match cmp with
+ Ceq -> x = y
+ | Cneq -> x <> y
+ | Clt -> x < y
+ | Cgt -> x > y
+ | Cle -> x <= y
+ | Cge -> x >= y)
let simplif_prim_pure p (args, approxs) dbg =
match approxs with
begin match p with
Pidentity -> make_const_int x
| Pnegint -> make_const_int (-x)
+ | Pbswap16 ->
+ make_const_int (((x land 0xff) lsl 8) lor
+ ((x land 0xff00) lsr 8))
| Poffsetint y -> make_const_int (x + y)
| _ -> (Uprim(p, args, dbg), Value_unknown)
end
| Plslint -> make_const_int(x lsl y)
| Plsrint -> make_const_int(x lsr y)
| Pasrint -> make_const_int(x asr y)
- | Pintcomp cmp ->
- let result = match cmp with
- Ceq -> x = y
- | Cneq -> x <> y
- | Clt -> x < y
- | Cgt -> x > y
- | Cle -> x <= y
- | Cge -> x >= y in
- make_const_bool result
+ | Pintcomp cmp -> make_comparison cmp x y
| _ -> (Uprim(p, args, dbg), Value_unknown)
end
| [Value_constptr x] ->
Pidentity -> make_const_ptr x
| Pnot -> make_const_bool(x = 0)
| Pisint -> make_const_bool true
+ | Pctconst c ->
+ begin
+ match c with
+ | Big_endian -> make_const_bool Arch.big_endian
+ | Word_size -> make_const_int (8*Arch.size_int)
+ | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
+ | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
+ | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
+ end
| _ -> (Uprim(p, args, dbg), Value_unknown)
end
| [Value_constptr x; Value_constptr y] ->
begin match p with
Psequand -> make_const_bool(x <> 0 && y <> 0)
| Psequor -> make_const_bool(x <> 0 || y <> 0)
+ | Pintcomp cmp -> make_comparison cmp x y
+ | _ -> (Uprim(p, args, dbg), Value_unknown)
+ end
+ | [Value_constptr x; Value_integer y] ->
+ begin match p with
+ | Pintcomp cmp -> make_comparison cmp x y
+ | _ -> (Uprim(p, args, dbg), Value_unknown)
+ end
+ | [Value_integer x; Value_constptr y] ->
+ begin match p with
+ | Pintcomp cmp -> make_comparison cmp x y
| _ -> (Uprim(p, args, dbg), Value_unknown)
end
| _ ->
id in
Uassign(id', substitute sb u)
| Usend(k, u1, u2, ul, dbg) ->
- Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg)
+ Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul,
+ dbg)
(* Perform an inline expansion *)
| Lconst cst ->
begin match cst with
Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n)
- | Const_base(Const_char c) -> (Uconst (cst,None), Value_integer(Char.code c))
+ | Const_base(Const_char c) -> (Uconst (cst,None),
+ Value_integer(Char.code c))
| Const_pointer n -> (Uconst (cst, None), Value_constptr n)
- | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown)
+ | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)),
+ Value_unknown)
end
| Lfunction(kind, params, body) as funct ->
close_one_function fenv cenv (Ident.create "fun") funct
when nargs < fundesc.fun_arity ->
let first_args = List.map (fun arg ->
(Ident.create "arg", arg) ) uargs in
- let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ ->
- Ident.create "arg")) in
+ let final_args =
+ Array.to_list (Array.init (fundesc.fun_arity - nargs)
+ (fun _ -> Ident.create "arg")) in
let rec iter args body =
match args with
[] -> body
match approx with
Value_tuple a when n < Array.length a -> a.(n)
| _ -> Value_unknown in
- check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox
+ check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none))
+ fieldapprox
| Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
let (ulam, approx) = close fenv cenv lam in
(!global_approx).(n) <- approx;
(* *)
(***********************************************************************)
-(* $Id: closure.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Introduction of closures, uncurrying, recognition of direct calls *)
val intro: int -> Lambda.lambda -> Clambda.ulambda
(* *)
(***********************************************************************)
-(* $Id: cmm.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
type machtype_component =
Addr
| Int
(* *)
(***********************************************************************)
-(* $Id: cmm.mli 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Second intermediate language (machine independent) *)
type machtype_component =
(* *)
(***********************************************************************)
-(* $Id: cmmgen.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Translation from closed lambda to C-- *)
open Misc
(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
let add_const c n =
- if n = 0 then c else Cop(Caddi, [c; Cconst_int n])
+ if n = 0 then c
+ else match c with
+ | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n)
+ | c -> Cop(Caddi, [c; Cconst_int n])
let incr_int = function
Cconst_int n when n < max_int -> Cconst_int(n+1)
Cop(Clsl, [c1; c2])
let ignore_low_bit_int = function
- Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c
+ Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n]) as c); Cconst_int 1]) when n > 0
+ -> c
| Cop(Cor, [c; Cconst_int 1]) -> c
| c -> c
+let lsr_int c1 c2 =
+ match c2 with
+ (Cconst_int n) when n > 0 ->
+ Cop(Clsr, [ignore_low_bit_int c1; c2])
+ | _ ->
+ Cop(Clsr, [c1; c2])
+
+let asr_int c1 c2 =
+ match c2 with
+ (Cconst_int n) when n > 0 ->
+ Cop(Casr, [ignore_low_bit_int c1; c2])
+ | _ ->
+ Cop(Casr, [c1; c2])
+
(* Division or modulo on tagged integers. The overflow case min_int / -1
cannot occur, but we must guard against division by zero. *)
| RHS_floatblock of int
| RHS_nonrec
;;
-let rec expr_size = function
+let rec expr_size env = function
+ | Uvar id ->
+ begin try Ident.find_same id env with Not_found -> RHS_nonrec end
| Uclosure(fundecls, clos_vars) ->
RHS_block (fundecls_size fundecls + List.length clos_vars)
| Ulet(id, exp, body) ->
- expr_size body
+ expr_size (Ident.add id (expr_size env exp) env) body
| Uletrec(bindings, body) ->
- expr_size body
+ expr_size env body
| Uprim(Pmakeblock(tag, mut), args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray(Pfloatarray), args, _) ->
RHS_floatblock (List.length args)
+ | Uprim (Pduprecord (Record_regular, sz), _, _) ->
+ RHS_block sz
+ | Uprim (Pduprecord (Record_float, sz), _, _) ->
+ RHS_floatblock sz
| Usequence(exp, exp') ->
- expr_size exp'
+ expr_size env exp'
| _ -> RHS_nonrec
(* Record application and currying functions *)
Pbigarray_complex32 | Pbigarray_complex64 ->
let kind = bigarray_word_kind elt_kind in
let sz = bigarray_elt_size elt_kind / 2 in
- bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
+ bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
+ (fun addr ->
box_complex
(Cop(Cload kind, [addr]))
(Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
let kind = bigarray_word_kind elt_kind in
let sz = bigarray_elt_size elt_kind / 2 in
bind "newval" newval (fun newv ->
- bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
+ bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
+ (fun addr ->
Csequence(
Cop(Cstore kind, [addr; complex_re newv]),
Cop(Cstore kind,
Cop(Cstore (bigarray_word_kind elt_kind),
[bigarray_indexing unsafe elt_kind layout b args dbg; newval]))
+let unaligned_load_16 ptr idx =
+ if Arch.allow_unaligned_access
+ then Cop(Cload Sixteen_unsigned, [add_int ptr idx])
+ else
+ let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in
+ let v2 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 1)]) in
+ let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
+ Cop(Cor, [lsl_int b1 (Cconst_int 8); b2])
+
+let unaligned_set_16 ptr idx newval =
+ if Arch.allow_unaligned_access
+ then Cop(Cstore Sixteen_unsigned, [add_int ptr idx; newval])
+ else
+ let v1 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in
+ let v2 = Cop(Cand, [newval; Cconst_int 0xFF]) in
+ let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
+ Csequence(
+ Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 1); b2]))
+
+let unaligned_load_32 ptr idx =
+ if Arch.allow_unaligned_access
+ then Cop(Cload Thirtytwo_unsigned, [add_int ptr idx])
+ else
+ let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in
+ let v2 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 1)]) in
+ let v3 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 2)]) in
+ let v4 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 3)]) in
+ let b1, b2, b3, b4 =
+ if Arch.big_endian
+ then v1, v2, v3, v4
+ else v4, v3, v2, v1 in
+ Cop(Cor,
+ [Cop(Cor, [lsl_int b1 (Cconst_int 24); lsl_int b2 (Cconst_int 16)]);
+ Cop(Cor, [lsl_int b3 (Cconst_int 8); b4])])
+
+let unaligned_set_32 ptr idx newval =
+ if Arch.allow_unaligned_access
+ then Cop(Cstore Thirtytwo_unsigned, [add_int ptr idx; newval])
+ else
+ let v1 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24]); Cconst_int 0xFF]) in
+ let v2 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16]); Cconst_int 0xFF]) in
+ let v3 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in
+ let v4 = Cop(Cand, [newval; Cconst_int 0xFF]) in
+ let b1, b2, b3, b4 =
+ if Arch.big_endian
+ then v1, v2, v3, v4
+ else v4, v3, v2, v1 in
+ Csequence(
+ Csequence(
+ Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 1); b2])),
+ Csequence(
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 2); b3]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 3); b4])))
+
+let unaligned_load_64 ptr idx =
+ assert(size_int = 8);
+ if Arch.allow_unaligned_access
+ then Cop(Cload Word, [add_int ptr idx])
+ else
+ let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in
+ let v2 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 1)]) in
+ let v3 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 2)]) in
+ let v4 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 3)]) in
+ let v5 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 4)]) in
+ let v6 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 5)]) in
+ let v7 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 6)]) in
+ let v8 = Cop(Cload Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 7)]) in
+ let b1, b2, b3, b4, b5, b6, b7, b8 =
+ if Arch.big_endian
+ then v1, v2, v3, v4, v5, v6, v7, v8
+ else v8, v7, v6, v5, v4, v3, v2, v1 in
+ Cop(Cor,
+ [Cop(Cor,
+ [Cop(Cor, [lsl_int b1 (Cconst_int (8*7));
+ lsl_int b2 (Cconst_int (8*6))]);
+ Cop(Cor, [lsl_int b3 (Cconst_int (8*5));
+ lsl_int b4 (Cconst_int (8*4))])]);
+ Cop(Cor,
+ [Cop(Cor, [lsl_int b5 (Cconst_int (8*3));
+ lsl_int b6 (Cconst_int (8*2))]);
+ Cop(Cor, [lsl_int b7 (Cconst_int 8);
+ b8])])])
+
+let unaligned_set_64 ptr idx newval =
+ assert(size_int = 8);
+ if Arch.allow_unaligned_access
+ then Cop(Cstore Word, [add_int ptr idx; newval])
+ else
+ let v1 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)]); Cconst_int 0xFF]) in
+ let v2 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)]); Cconst_int 0xFF]) in
+ let v3 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)]); Cconst_int 0xFF]) in
+ let v4 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)]); Cconst_int 0xFF]) in
+ let v5 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)]); Cconst_int 0xFF]) in
+ let v6 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)]); Cconst_int 0xFF]) in
+ let v7 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in
+ let v8 = Cop(Cand, [newval; Cconst_int 0xFF]) in
+ let b1, b2, b3, b4, b5, b6, b7, b8 =
+ if Arch.big_endian
+ then v1, v2, v3, v4, v5, v6, v7, v8
+ else v8, v7, v6, v5, v4, v3, v2, v1 in
+ Csequence(
+ Csequence(
+ Csequence(
+ Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 1); b2])),
+ Csequence(
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 2); b3]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 3); b4]))),
+ Csequence(
+ Csequence(
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 4); b5]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 5); b6])),
+ Csequence(
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 6); b7]),
+ Cop(Cstore Byte_unsigned,
+ [add_int (add_int ptr idx) (Cconst_int 7); b8]))))
+
+let check_bound unsafe dbg a1 a2 k =
+ if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k)
+
(* Simplification of some primitives into C calls *)
let default_prim name =
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, Pbigarray_int64, layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
+ | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64")
+ | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64")
+ | Pbigstring_load_64(_) -> Pccall (default_prim "caml_ba_uint8_get64")
+ | Pbigstring_set_64(_) -> Pccall (default_prim "caml_ba_uint8_set64")
+ | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
| p -> p
let simplif_primitive p =
let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))
-exception Found of int
-
let make_switch_gen arg cases acts =
let lcases = Array.length cases in
let new_cases = Array.create lcases 0 in
Boxed_float
| Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32
| Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64
- | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint
+ | Pbigarrayref(_, _, Pbigarray_native_int,_) -> Boxed_integer Pnativeint
+ | Pstring_load_32(_) -> Boxed_integer Pint32
+ | Pstring_load_64(_) -> Boxed_integer Pint64
+ | Pbigstring_load_32(_) -> Boxed_integer Pint32
+ | Pbigstring_load_64(_) -> Boxed_integer Pint64
+ | Pbbswap bi -> Boxed_integer bi
| _ -> No_unboxing
end
| _ -> No_unboxing
(Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg),
List.map transl_unbox_float args))
else
- Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg),
+ Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc,
+ dbg),
List.map transl args)
| (Pmakearray kind, []) ->
transl_constant(Const_block(0, []))
| Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval
| _ -> untag_int (transl argnewval))
dbg)
+ | (Pbigarraydim(n), [b]) ->
+ let dim_ofs = 4 + n in
+ tag_int (Cop(Cload Word, [field_address (transl b) dim_ofs]))
| (p, [arg]) ->
transl_prim_1 p arg dbg
| (p, [arg1; arg2]) ->
(* Integer operations *)
| Pnegint ->
Cop(Csubi, [Cconst_int 2; transl arg])
+ | Pctconst c ->
+ let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) in
+ begin
+ match c with
+ | Big_endian -> const_of_bool Arch.big_endian
+ | Word_size -> tag_int (Cconst_int (8*Arch.size_int))
+ | Ostype_unix -> const_of_bool (Sys.os_type = "Unix")
+ | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32")
+ | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin")
+ end
| Poffsetint n ->
if no_overflow_lsl n then
add_const (transl arg) (n lsl 1)
else
- transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) Debuginfo.none
+ transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None))
+ Debuginfo.none
| Poffsetref n ->
return_unit
(bind "ref" (transl arg) (fun arg ->
box_int bi2 (transl_unbox_int bi1 arg)
| Pnegbint bi ->
box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg]))
+ | Pbbswap bi ->
+ let prim = match bi with
+ | Pnativeint -> "nativeint"
+ | Pint32 -> "int32"
+ | Pint64 -> "int64" in
+ box_int bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
+ typ_int, false, Debuginfo.none),
+ [transl_unbox_int bi arg]))
+ | Pbswap16 ->
+ tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false,
+ Debuginfo.none),
+ [untag_int (transl arg)]))
| _ ->
fatal_error "Cmmgen.transl_prim_1"
(* Heap operations *)
Psetfield(n, ptr) ->
if ptr then
- return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
+ return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
[field_address (transl arg1) n; transl arg2]))
else
return_unit(set_field (transl arg1) n (transl arg2))
| Pmulint ->
incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)]))
| Pdivint ->
- tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
+ tag_int(safe_divmod Cdivi (untag_int(transl arg1))
+ (untag_int(transl arg2)) dbg)
| Pmodint ->
- tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
+ tag_int(safe_divmod Cmodi (untag_int(transl arg1))
+ (untag_int(transl arg2)) dbg)
| Pandint ->
Cop(Cand, [transl arg1; transl arg2])
| Porint ->
| Plslint ->
incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2)))
| Plsrint ->
- Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]);
+ Cop(Cor, [lsr_int (transl arg1) (untag_int(transl arg2));
Cconst_int 1])
| Pasrint ->
- Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]);
+ Cop(Cor, [asr_int (transl arg1) (untag_int(transl arg2));
Cconst_int 1])
| Pintcomp cmp ->
tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2]))
make_checkbound dbg [string_length str; idx],
Cop(Cload Byte_unsigned, [add_int str idx])))))
+ | Pstring_load_16(unsafe) ->
+ tag_int
+ (bind "str" (transl arg1) (fun str ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1))
+ idx (unaligned_load_16 str idx))))
+
+ | Pbigstring_load_16(unsafe) ->
+ tag_int
+ (bind "ba" (transl arg1) (fun ba ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data ->
+ check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5]))
+ (Cconst_int 1)) idx
+ (unaligned_load_16 ba_data idx)))))
+
+ | Pstring_load_32(unsafe) ->
+ box_int Pint32
+ (bind "str" (transl arg1) (fun str ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3))
+ idx (unaligned_load_32 str idx))))
+
+ | Pbigstring_load_32(unsafe) ->
+ box_int Pint32
+ (bind "ba" (transl arg1) (fun ba ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data ->
+ check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5]))
+ (Cconst_int 3)) idx
+ (unaligned_load_32 ba_data idx)))))
+
+ | Pstring_load_64(unsafe) ->
+ box_int Pint64
+ (bind "str" (transl arg1) (fun str ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7))
+ idx (unaligned_load_64 str idx))))
+
+ | Pbigstring_load_64(unsafe) ->
+ box_int Pint64
+ (bind "ba" (transl arg1) (fun ba ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data ->
+ check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5]))
+ (Cconst_int 7)) idx
+ (unaligned_load_64 ba_data idx)))))
+
(* Array operations *)
| Parrayrefu kind ->
begin match kind with
float_array_ref arr idx)))))
| Paddrarray | Pintarray ->
bind "index" (transl arg2) (fun idx ->
- bind "arr" (transl arg1) (fun arr ->
- Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
- addr_array_ref arr idx)))
+ bind "arr" (transl arg1) (fun arr ->
+ Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
+ addr_array_ref arr idx)))
| Pfloatarray ->
box_float(
bind "index" (transl arg2) (fun idx ->
- bind "arr" (transl arg1) (fun arr ->
- Csequence(make_checkbound dbg [float_array_length(header arr); idx],
- unboxed_float_array_ref arr idx))))
+ bind "arr" (transl arg1) (fun arr ->
+ Csequence(make_checkbound dbg
+ [float_array_length(header arr); idx],
+ unboxed_float_array_ref arr idx))))
end
(* Operations on bitvects *)
Csequence(make_checkbound dbg [float_array_length(header arr);idx],
float_array_set arr idx newval))))
end)
+
+ | Pstring_set_16(unsafe) ->
+ return_unit
+ (bind "str" (transl arg1) (fun str ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "newval" (untag_int (transl arg3)) (fun newval ->
+ check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1))
+ idx (unaligned_set_16 str idx newval)))))
+
+ | Pbigstring_set_16(unsafe) ->
+ return_unit
+ (bind "ba" (transl arg1) (fun ba ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "newval" (untag_int (transl arg3)) (fun newval ->
+ bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data ->
+ check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5]))
+ (Cconst_int 1))
+ idx (unaligned_set_16 ba_data idx newval))))))
+
+ | Pstring_set_32(unsafe) ->
+ return_unit
+ (bind "str" (transl arg1) (fun str ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "newval" (transl_unbox_int Pint32 arg3) (fun newval ->
+ check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3))
+ idx (unaligned_set_32 str idx newval)))))
+
+ | Pbigstring_set_32(unsafe) ->
+ return_unit
+ (bind "ba" (transl arg1) (fun ba ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "newval" (transl_unbox_int Pint32 arg3) (fun newval ->
+ bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data ->
+ check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5]))
+ (Cconst_int 3))
+ idx (unaligned_set_32 ba_data idx newval))))))
+
+ | Pstring_set_64(unsafe) ->
+ return_unit
+ (bind "str" (transl arg1) (fun str ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "newval" (transl_unbox_int Pint64 arg3) (fun newval ->
+ check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7))
+ idx (unaligned_set_64 str idx newval)))))
+
+ | Pbigstring_set_64(unsafe) ->
+ return_unit
+ (bind "ba" (transl arg1) (fun ba ->
+ bind "index" (untag_int (transl arg2)) (fun idx ->
+ bind "newval" (transl_unbox_int Pint64 arg3) (fun newval ->
+ bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data ->
+ check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5]))
+ (Cconst_int 7)) idx
+ (unaligned_set_64 ba_data idx newval))))))
+
| _ ->
fatal_error "Cmmgen.transl_prim_3"
Cconst_natint n
| Uconst(Const_base(Const_int64 n), _) ->
assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
- | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i),_)], _) when bi = bi' ->
+ | Uprim(Pbintofint bi',[Uconst(Const_base(Const_int i),_)],_) when bi = bi' ->
Cconst_int i
| exp -> unbox_int bi (transl exp)
(Array.of_list !inters) actions)
and transl_letrec bindings cont =
- let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in
+ let bsz =
+ List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in
let op_alloc prim sz =
Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in
let rec init_blocks = function
module StringSet =
Set.Make(struct
type t = string
- let compare = compare
+ let compare (x:t) y = compare x y
end)
let rec transl_all_functions already_translated cont =
clos clos1.vars[1])
(app clos.direct
clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos)))
+
Special "shortcut" functions are also generated to handle the
case where a partially applied function is applied to all remaining
arguments in one go. For instance:
(defun caml_curry_N_1_app (arg2 ... argN clos)
(let clos' clos.vars[1]
(app clos'.direct clos.vars[0] arg2 ... argN clos')))
+
+ Those shortcuts may lead to a quadratic number of application
+ primitives being generated in the worst case, which resulted in
+ linking time blowup in practice (PR#5933), so we only generate and
+ use them when below a fixed arity 'max_arity_optimized'.
*)
+let max_arity_optimized = 15
let final_curry_function arity =
let last_arg = Ident.create "arg" in
let last_clos = Ident.create "clos" in
get_field (Cvar clos) 2 ::
args @ [Cvar last_arg; Cvar clos])
else
- if n = arity - 1 then
+ if n = arity - 1 || arity > max_arity_optimized then
begin
let newclos = Ident.create "clos" in
Clet(newclos,
{fun_name = name2;
fun_args = [arg, typ_addr; clos, typ_addr];
fun_body =
- if arity - num > 2 then
+ if arity - num > 2 && arity <= max_arity_optimized then
Cop(Calloc,
[alloc_closure_header 5;
Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
fun_fast = true;
fun_dbg = Debuginfo.none }
::
- (if arity - num > 2 then
+ (if arity <= max_arity_optimized && arity - num > 2 then
let rec iter i =
if i <= arity then
let arg = Ident.create (Printf.sprintf "arg%d" i) in
module IntSet = Set.Make(
struct
type t = int
- let compare = compare
+ let compare (x:t) y = compare x y
end)
let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty)
(* *)
(***********************************************************************)
-(* $Id: cmmgen.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Translation from closed lambda to C-- *)
val compunit: int -> Clambda.ulambda -> Cmm.phrase list
(* *)
(***********************************************************************)
-(* $Id: cmx_format.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Format of .cmx, .cmxa and .cmxs files *)
(* Each .o file has a matching .cmx file that provides the following infos
mutable ui_defines: string list; (* Unit and sub-units implemented *)
mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
- mutable ui_approx: Clambda.value_approximation; (* Approx of the structure *)
+ mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*)
mutable ui_curry_fun: int list; (* Currying functions needed *)
mutable ui_apply_fun: int list; (* Apply functions needed *)
mutable ui_send_fun: int list; (* Send functions needed *)
(* *)
(***********************************************************************)
-(* $Id: codegen.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* From C-- to assembly code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: codegen.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* From C-- to assembly code *)
val phrase: Cmm.phrase -> unit
(* *)
(***********************************************************************)
-(* $Id: coloring.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Register allocation by coloring of the interference graph *)
-open Reg
+module OrderedRegSet =
+ Set.Make(struct
+ type t = Reg.t
+ let compare r1 r2 =
+ let open Reg in
+ let c1 = r1.spill_cost and d1 = r1.degree in
+ let c2 = r2.spill_cost and d2 = r2.degree in
+ let n = c2 * d1 - c1 * d2 in
+ if n <> 0 then n else
+ let n = c2 - c1 in
+ if n <> 0 then n else
+ let n = d1 - d2 in
+ if n <> 0 then n else r1.stamp - r2.stamp
+ end)
-(* Preallocation of spilled registers in the stack. *)
+open Reg
-let allocate_spilled reg =
- if reg.spill then begin
- let cl = Proc.register_class reg in
- let nslots = Proc.num_stack_slots.(cl) in
- let conflict = Array.create nslots false in
- List.iter
- (fun r ->
- match r.loc with
- Stack(Local n) ->
- if Proc.register_class r = cl then conflict.(n) <- true
- | _ -> ())
- reg.interf;
- let slot = ref 0 in
- while !slot < nslots && conflict.(!slot) do incr slot done;
- reg.loc <- Stack(Local !slot);
- if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1
- end
+let allocate_registers() =
-(* Compute the degree (= number of neighbours of the same type)
- of each register, and split them in two sets:
- unconstrained (degree < number of available registers)
- and constrained (degree >= number of available registers).
- Spilled registers are ignored in the process. *)
+ (* Constrained regs with degree >= number of available registers,
+ sorted by spill cost (highest first).
+ The spill cost measure is [r.spill_cost / r.degree].
+ [r.spill_cost] estimates the number of accesses to [r]. *)
+ let constrained = ref OrderedRegSet.empty in
-let unconstrained = ref Reg.Set.empty
-let constrained = ref Reg.Set.empty
+ (* Unconstrained regs with degree < number of available registers *)
+ let unconstrained = ref [] in
-let find_degree reg =
- if reg.spill then () else begin
+ (* Preallocate the spilled registers in the stack.
+ Split the remaining registers into constrained and unconstrained. *)
+ let remove_reg reg =
let cl = Proc.register_class reg in
- let avail_regs = Proc.num_available_registers.(cl) in
- if avail_regs = 0 then
- (* Don't bother computing the degree if there are no regs
- in this class *)
- unconstrained := Reg.Set.add reg !unconstrained
- else begin
- let deg = ref 0 in
+ if reg.spill then begin
+ (* Preallocate the registers in the stack *)
+ let nslots = Proc.num_stack_slots.(cl) in
+ let conflict = Array.create nslots false in
List.iter
- (fun r -> if not r.spill && Proc.register_class r = cl then incr deg)
+ (fun r ->
+ match r.loc with
+ Stack(Local n) ->
+ if Proc.register_class r = cl then conflict.(n) <- true
+ | _ -> ())
reg.interf;
- reg.degree <- !deg;
- if !deg >= avail_regs
- then constrained := Reg.Set.add reg !constrained
- else unconstrained := Reg.Set.add reg !unconstrained
- end
- end
-
-(* Remove a register from the interference graph *)
-
-let remove_reg reg =
- reg.degree <- 0; (* 0 means r is no longer part of the graph *)
- let cl = Proc.register_class reg in
- List.iter
- (fun r ->
- if Proc.register_class r = cl && r.degree > 0 then begin
- let olddeg = r.degree in
- r.degree <- olddeg - 1;
- if olddeg = Proc.num_available_registers.(cl) then begin
- (* r was constrained and becomes unconstrained *)
- constrained := Reg.Set.remove r !constrained;
- unconstrained := Reg.Set.add r !unconstrained
- end
- end)
- reg.interf
-
-(* Remove all registers one by one, unconstrained if possible, otherwise
- constrained with lowest spill cost. Return the list of registers removed
- in reverse order.
- The spill cost measure is [r.spill_cost / r.degree].
- [r.spill_cost] estimates the number of accesses to this register. *)
-
-let rec remove_all_regs stack =
- if not (Reg.Set.is_empty !unconstrained) then begin
- (* Pick any unconstrained register *)
- let r = Reg.Set.choose !unconstrained in
- unconstrained := Reg.Set.remove r !unconstrained;
- remove_all_regs (r :: stack)
- end else
- if not (Reg.Set.is_empty !constrained) then begin
- (* Find a constrained reg with minimal cost *)
- let r = ref Reg.dummy in
- let min_degree = ref 0 and min_spill_cost = ref 1 in
- (* initially !min_spill_cost / !min_degree is +infty *)
- Reg.Set.iter
- (fun r2 ->
- (* if r2.spill_cost / r2.degree < !min_spill_cost / !min_degree *)
- if r2.spill_cost * !min_degree < !min_spill_cost * r2.degree
- then begin
- r := r2; min_degree := r2.degree; min_spill_cost := r2.spill_cost
- end)
- !constrained;
- constrained := Reg.Set.remove !r !constrained;
- remove_all_regs (!r :: stack)
- end else
- stack (* All regs have been removed *)
-
-(* Iterate over all registers preferred by the given register (transitively) *)
-
-let iter_preferred f reg =
- let rec walk r w =
- if not r.visited then begin
- f r w;
- begin match r.prefer with
- [] -> ()
- | p -> r.visited <- true;
- List.iter (fun (r1, w1) -> walk r1 (min w w1)) p;
- r.visited <- false
- end
+ let slot = ref 0 in
+ while !slot < nslots && conflict.(!slot) do incr slot done;
+ reg.loc <- Stack(Local !slot);
+ if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1
+ end else if reg.degree < Proc.num_available_registers.(cl) then
+ unconstrained := reg :: !unconstrained
+ else begin
+ constrained := OrderedRegSet.add reg !constrained
end in
- reg.visited <- true;
- List.iter (fun (r, w) -> walk r w) reg.prefer;
- reg.visited <- false
-
-(* Where to start the search for a suitable register.
- Used to introduce some "randomness" in the choice between registers
- with equal scores. This offers more opportunities for scheduling. *)
-
-let start_register = Array.create Proc.num_register_classes 0
-(* Assign a location to a register, the best we can *)
-
-let assign_location reg =
- let cl = Proc.register_class reg in
- let first_reg = Proc.first_available_register.(cl) in
- let num_regs = Proc.num_available_registers.(cl) in
- let last_reg = first_reg + num_regs in
- let score = Array.create num_regs 0 in
- let best_score = ref (-1000000) and best_reg = ref (-1) in
- let start = start_register.(cl) in
- if num_regs > 0 then begin
- (* Favor the registers that have been assigned to pseudoregs for which
- we have a preference. If these pseudoregs have not been assigned
- already, avoid the registers with which they conflict. *)
- iter_preferred
- (fun r w ->
- match r.loc with
- Reg n -> if n >= first_reg && n < last_reg then
- score.(n - first_reg) <- score.(n - first_reg) + w
- | Unknown ->
- List.iter
- (fun neighbour ->
- match neighbour.loc with
- Reg n -> if n >= first_reg && n < last_reg then
- score.(n - first_reg) <- score.(n - first_reg) - w
- | _ -> ())
- r.interf
- | _ -> ())
- reg;
- List.iter
- (fun neighbour ->
- (* Prohibit the registers that have been assigned
- to our neighbours *)
- begin match neighbour.loc with
- Reg n -> if n >= first_reg && n < last_reg then
- score.(n - first_reg) <- (-1000000)
- | _ -> ()
- end;
- (* Avoid the registers that have been assigned to pseudoregs
- for which our neighbours have a preference *)
- iter_preferred
- (fun r w ->
- match r.loc with
- Reg n -> if n >= first_reg && n < last_reg then
- score.(n - first_reg) <- score.(n - first_reg) - (w - 1)
- (* w-1 to break the symmetry when two conflicting regs
- have the same preference for a third reg. *)
- | _ -> ())
- neighbour)
- reg.interf;
- (* Pick the register with the best score *)
- for n = start to num_regs - 1 do
- if score.(n) > !best_score then begin
- best_score := score.(n);
- best_reg := n
- end
- done;
- for n = 0 to start - 1 do
- if score.(n) > !best_score then begin
- best_score := score.(n);
- best_reg := n
- end
- done
- end;
- (* Found a register? *)
- if !best_reg >= 0 then begin
- reg.loc <- Reg(first_reg + !best_reg);
- if Proc.rotate_registers then
- start_register.(cl) <- (if start+1 >= num_regs then 0 else start+1)
- end else begin
- (* Sorry, we must put the pseudoreg in a stack location *)
- let nslots = Proc.num_stack_slots.(cl) in
- let score = Array.create nslots 0 in
- (* Compute the scores as for registers *)
- List.iter
- (fun (r, w) ->
- match r.loc with
- Stack(Local n) -> if Proc.register_class r = cl then
- score.(n) <- score.(n) + w
- | Unknown ->
- List.iter
- (fun neighbour ->
- match neighbour.loc with
- Stack(Local n) ->
- if Proc.register_class neighbour = cl
- then score.(n) <- score.(n) - w
- | _ -> ())
- r.interf
- | _ -> ())
- reg.prefer;
- List.iter
- (fun neighbour ->
- begin match neighbour.loc with
- Stack(Local n) ->
- if Proc.register_class neighbour = cl then
- score.(n) <- (-1000000)
- | _ -> ()
- end;
- List.iter
- (fun (r, w) ->
- match r.loc with
- Stack(Local n) -> if Proc.register_class r = cl then
- score.(n) <- score.(n) - w
- | _ -> ())
- neighbour.prefer)
- reg.interf;
- (* Pick the location with the best score *)
- let best_score = ref (-1000000) and best_slot = ref (-1) in
- for n = 0 to nslots - 1 do
- if score.(n) > !best_score then begin
- best_score := score.(n);
- best_slot := n
+ (* Iterate over all registers preferred by the given register (transitive) *)
+ let iter_preferred f reg =
+ let rec walk r w =
+ if not r.visited then begin
+ f r w;
+ begin match r.prefer with
+ [] -> ()
+ | p -> r.visited <- true;
+ List.iter (fun (r1, w1) -> walk r1 (min w w1)) p;
+ r.visited <- false
+ end
+ end in
+ reg.visited <- true;
+ List.iter (fun (r, w) -> walk r w) reg.prefer;
+ reg.visited <- false in
+
+ (* Where to start the search for a suitable register.
+ Used to introduce some "randomness" in the choice between registers
+ with equal scores. This offers more opportunities for scheduling. *)
+ let start_register = Array.create Proc.num_register_classes 0 in
+
+ (* Assign a location to a register, the best we can. *)
+ let assign_location reg =
+ let cl = Proc.register_class reg in
+ let first_reg = Proc.first_available_register.(cl) in
+ let num_regs = Proc.num_available_registers.(cl) in
+ let score = Array.create num_regs 0 in
+ let best_score = ref (-1000000) and best_reg = ref (-1) in
+ let start = start_register.(cl) in
+ if num_regs <> 0 then begin
+ (* Favor the registers that have been assigned to pseudoregs for which
+ we have a preference. If these pseudoregs have not been assigned
+ already, avoid the registers with which they conflict. *)
+ iter_preferred
+ (fun r w ->
+ match r.loc with
+ Reg n -> let n = n - first_reg in
+ if n < num_regs then
+ score.(n) <- score.(n) + w
+ | Unknown ->
+ List.iter
+ (fun neighbour ->
+ match neighbour.loc with
+ Reg n -> let n = n - first_reg in
+ if n < num_regs then
+ score.(n) <- score.(n) - w
+ | _ -> ())
+ r.interf
+ | _ -> ())
+ reg;
+ List.iter
+ (fun neighbour ->
+ (* Prohibit the registers that have been assigned
+ to our neighbours *)
+ begin match neighbour.loc with
+ Reg n -> let n = n - first_reg in
+ if n < num_regs then
+ score.(n) <- (-1000000)
+ | _ -> ()
+ end;
+ (* Avoid the registers that have been assigned to pseudoregs
+ for which our neighbours have a preference *)
+ iter_preferred
+ (fun r w ->
+ match r.loc with
+ Reg n -> let n = n - first_reg in
+ if n < num_regs then
+ score.(n) <- score.(n) - (w-1)
+ (* w-1 to break the symmetry when two conflicting regs
+ have the same preference for a third reg. *)
+ | _ -> ())
+ neighbour)
+ reg.interf;
+ (* Pick the register with the best score *)
+ for n = start to num_regs - 1 do
+ if score.(n) > !best_score then begin
+ best_score := score.(n);
+ best_reg := n
+ end
+ done;
+ for n = 0 to start - 1 do
+ if score.(n) > !best_score then begin
+ best_score := score.(n);
+ best_reg := n
+ end
+ done
+ end;
+ (* Found a register? *)
+ if !best_reg >= 0 then begin
+ reg.loc <- Reg(first_reg + !best_reg);
+ if Proc.rotate_registers then
+ start_register.(cl) <- (let start = start + 1 in
+ if start >= num_regs then 0 else start)
+ end else begin
+ (* Sorry, we must put the pseudoreg in a stack location *)
+ let nslots = Proc.num_stack_slots.(cl) in
+ let score = Array.create nslots 0 in
+ (* Compute the scores as for registers *)
+ List.iter
+ (fun (r, w) ->
+ match r.loc with
+ Stack(Local n) -> score.(n) <- score.(n) + w
+ | Unknown ->
+ List.iter
+ (fun neighbour ->
+ match neighbour.loc with
+ Stack(Local n) -> score.(n) <- score.(n) - w
+ | _ -> ())
+ r.interf
+ | _ -> ())
+ reg.prefer;
+ List.iter
+ (fun neighbour ->
+ begin match neighbour.loc with
+ Stack(Local n) -> score.(n) <- (-1000000)
+ | _ -> ()
+ end;
+ List.iter
+ (fun (r, w) ->
+ match r.loc with
+ Stack(Local n) -> score.(n) <- score.(n) - w
+ | _ -> ())
+ neighbour.prefer)
+ reg.interf;
+ (* Pick the location with the best score *)
+ let best_score = ref (-1000000) and best_slot = ref (-1) in
+ for n = 0 to nslots - 1 do
+ if score.(n) > !best_score then begin
+ best_score := score.(n);
+ best_slot := n
+ end
+ done;
+ (* Found one? *)
+ if !best_slot >= 0 then
+ reg.loc <- Stack(Local !best_slot)
+ else begin
+ (* Allocate a new stack slot *)
+ reg.loc <- Stack(Local nslots);
+ Proc.num_stack_slots.(cl) <- nslots + 1
end
- done;
- (* Found one? *)
- if !best_slot >= 0 then
- reg.loc <- Stack(Local !best_slot)
- else begin
- (* Allocate a new stack slot *)
- reg.loc <- Stack(Local nslots);
- Proc.num_stack_slots.(cl) <- nslots + 1
- end
- end;
- (* Cancel the preferences of this register so that they don't influence
- transitively the allocation of registers that prefer this reg. *)
- reg.prefer <- []
+ end;
+ (* Cancel the preferences of this register so that they don't influence
+ transitively the allocation of registers that prefer this reg. *)
+ reg.prefer <- [] in
-let allocate_registers() =
- (* First pass: preallocate spill registers
- Second pass: compute the degrees
- Third pass: determine coloring order by successive removals of regs
- Fourth pass: assign registers in that order *)
+ (* Reset the stack slot counts *)
for i = 0 to Proc.num_register_classes - 1 do
Proc.num_stack_slots.(i) <- 0;
- start_register.(i) <- 0
done;
- List.iter allocate_spilled (Reg.all_registers());
- List.iter find_degree (Reg.all_registers());
- List.iter assign_location (remove_all_regs [])
+
+ (* First pass: preallocate spill registers and split remaining regs
+ Second pass: assign locations to constrained regs
+ Third pass: assign locations to unconstrained regs *)
+ List.iter remove_reg (Reg.all_registers());
+ OrderedRegSet.iter assign_location !constrained;
+ List.iter assign_location !unconstrained
(* *)
(***********************************************************************)
-(* $Id: coloring.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Register allocation by coloring of the interference graph *)
val allocate_registers: unit -> unit
(* *)
(***********************************************************************)
-(* $Id: comballoc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Combine heap allocations occurring in the same basic block *)
open Mach
(* *)
(***********************************************************************)
-(* $Id: comballoc.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Combine heap allocations occurring in the same basic block *)
val fundecl: Mach.fundecl -> Mach.fundecl
(* *)
(***********************************************************************)
-(* $Id: compilenv.ml 12202 2012-03-07 17:50:17Z frisch $ *)
-
(* Compilation environments for compilation units *)
open Config
type error =
Not_a_unit_info of string
| Corrupted_unit_info of string
- | Illegal_renaming of string * string
+ | Illegal_renaming of string * string * string
exception Error of error
let global_infos_table =
(Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
-let structured_constants = ref ([] : (string * bool * Lambda.structured_constant) list)
+let structured_constants =
+ ref ([] : (string * bool * Lambda.structured_constant) list)
let current_unit =
{ ui_name = "";
let cmx_not_found_crc =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
-let get_global_info global_ident =
+let get_global_info global_ident = (
let modname = Ident.name global_ident in
if modname = current_unit.ui_name then
Some current_unit
find_in_path_uncap !load_path (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
- raise(Error(Illegal_renaming(ui.ui_name, filename)));
+ raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
(Some ui, crc)
with Not_found ->
(None, cmx_not_found_crc) in
Hashtbl.add global_infos_table modname infos;
infos
end
+)
let cache_unit_info ui =
Hashtbl.add global_infos_table ui.ui_name (Some ui)
| Corrupted_unit_info filename ->
fprintf ppf "Corrupted compilation unit description@ %a"
Location.print_filename filename
- | Illegal_renaming(modname, filename) ->
- fprintf ppf "%a@ contains the description for unit@ %s"
- Location.print_filename filename modname
+ | Illegal_renaming(name, modname, filename) ->
+ fprintf ppf "%a@ contains the description for unit\
+ @ %s when %s was expected"
+ Location.print_filename filename name modname
(* *)
(***********************************************************************)
-(* $Id: compilenv.mli 12210 2012-03-08 19:52:03Z doligez $ *)
-
(* Compilation environments for compilation units *)
-open Clambda
open Cmx_format
val reset: ?packname:string -> string -> unit
val new_const_symbol : unit -> string
val new_const_label : unit -> int
val new_structured_constant : Lambda.structured_constant -> bool -> string
-val structured_constants : unit -> (string * bool * Lambda.structured_constant) list
+val structured_constants :
+ unit -> (string * bool * Lambda.structured_constant) list
val read_unit_info: string -> unit_infos * Digest.t
(* Read infos and MD5 from a [.cmx] file. *)
type error =
Not_a_unit_info of string
| Corrupted_unit_info of string
- | Illegal_renaming of string * string
+ | Illegal_renaming of string * string * string
exception Error of error
(* *)
(***********************************************************************)
-(* $Id: emit.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Generation of assembly code *)
val fundecl: Linearize.fundecl -> unit
(* *)
(***********************************************************************)
-(* $Id: emitaux.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Common functions for emitting assembly code *)
open Debuginfo
-open Cmm
-open Reg
-open Linearize
let output_channel = ref stdout
let emit_frames a =
let filenames = Hashtbl.create 7 in
- let lbl_filenames = ref 200000 in
let label_filename name =
try
Hashtbl.find filenames name
with Not_found ->
- let lbl = !lbl_filenames in
+ let lbl = Linearize.new_label () in
Hashtbl.add filenames name lbl;
- incr lbl_filenames;
lbl in
let emit_frame fd =
a.efa_label fd.fd_lbl;
display .loc for every instruction. *)
let emit_debug_info dbg =
if is_cfi_enabled () &&
- !Clflags.debug && not (Debuginfo.is_none dbg) then begin
+ (!Clflags.debug || Config.with_frame_pointers)
+ && not (Debuginfo.is_none dbg) then begin
let line = dbg.Debuginfo.dinfo_line in
assert (line <> 0); (* clang errors out on zero line numbers *)
let file_name = dbg.Debuginfo.dinfo_file in
(* *)
(***********************************************************************)
-(* $Id: emitaux.mli 12448 2012-05-12 09:49:40Z xleroy $ *)
-
(* Common functions for emitting assembly code *)
val output_channel: out_channel ref
(* *)
(***********************************************************************)
-(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *)
-
(* Machine-specific command-line options *)
let fast_math = ref false
(* Specific operations for the Intel 386 processor *)
-open Misc
open Format
type addressing_mode =
let size_int = 4
let size_float = 8
+let allow_unaligned_access = true
+
(* Behavior of division *)
let division_crashes_on_overflow = true
(* *)
(***********************************************************************)
-(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Emission of Intel 386 assembly code *)
-module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringSet =
+ Set.Make(struct type t = string let compare (x:t) y = compare x y end)
-open Location
open Misc
open Cmm
open Arch
| "tan" -> ` fptan; fstp %st(0)\n`
| _ -> assert false
+(* Floating-point constants *)
+
+let float_constants = ref ([] : (string * int) list)
+
+let add_float_constant cst =
+ try
+ List.assoc cst !float_constants
+ with
+ Not_found ->
+ let lbl = new_label() in
+ float_constants := (cst, lbl) :: !float_constants;
+ lbl
+
+let emit_float_constant (cst, lbl) =
+ `{emit_label lbl}:`;
+ emit_float64_split_directive ".long" cst
+
(* Output the assembly code for an instruction *)
(* Name of current function *)
let tailrec_entry_point = ref 0
(* Label of trap for out-of-range accesses *)
let range_check_trap = ref 0
-(* Record float literals to be emitted later *)
-let float_constants = ref ([] : (int * string) list)
(* Record references to external C functions (for MacOSX) *)
let external_symbols_direct = ref StringSet.empty
let external_symbols_indirect = ref StringSet.empty
| 0xBFF0_0000_0000_0000L -> (* -1.0 *)
` fld1\n fchs\n`
| _ ->
- let lbl = new_label() in
- float_constants := (lbl, s) :: !float_constants;
+ let lbl = add_float_constant s in
` fldl {emit_label lbl}\n`
end
| Lop(Iconst_symbol s) ->
(Linearize.has_fallthrough i.desc)
i.next
-(* Emission of the floating-point constants *)
-
-let emit_float_constant (lbl, cst) =
- ` .data\n`;
- `{emit_label lbl}:`;
- emit_float64_split_directive ".long" cst
-
(* Emission of external symbol references (for MacOSX) *)
let emit_external_symbol_direct s =
fastcode_flag := fundecl.fun_fast;
tailrec_entry_point := new_label();
stack_offset := 0;
- float_constants := [];
call_gc_sites := [];
bound_error_sites := [];
bound_error_call := 0;
"linux_elf" | "bsd_elf" | "gnu" ->
` .type {emit_symbol fundecl.fun_name},@function\n`;
` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n`
- | _ -> () end;
- List.iter emit_float_constant !float_constants
+ | _ -> () end
(* Emission of data *)
let begin_assembly() =
reset_debug_info(); (* PR#5603 *)
+ float_constants := [];
let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
` .data\n`;
` .globl {emit_symbol lbl_begin}\n`;
if macosx then ` nop\n` (* PR#4690 *)
let end_assembly() =
+ if !float_constants <> [] then begin
+ ` .data\n`;
+ List.iter emit_float_constant !float_constants
+ end;
let lbl_end = Compilenv.make_symbol (Some "code_end") in
` .text\n`;
if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *)
(* *)
(***********************************************************************)
-(* $Id: emit_nt.mlp 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Emission of Intel 386 assembly code, MASM syntax. *)
module StringSet =
- Set.Make(struct type t = string let compare = compare end)
+ Set.Make(struct type t = string let compare (x:t) y = compare x y end)
open Misc
open Cmm
| "tan" -> ` fptan\n\tfstp st(0)\n`
| _ -> assert false
+(* Floating-point constants *)
+
+let float_constants = ref ([] : (string * int) list)
+
+let add_float_constant cst =
+ try
+ List.assoc cst !float_constants
+ with
+ Not_found ->
+ let lbl = new_label() in
+ float_constants := (cst, lbl) :: !float_constants;
+ lbl
+
+let emit_float s =
+ (* MASM doesn't like floating-point constants such as 2e9.
+ Turn them into 2.0e9. *)
+ let pos_e = ref (-1) and pos_dot = ref (-1) in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ 'e'|'E' -> pos_e := i
+ | '.' -> pos_dot := i
+ | _ -> ()
+ done;
+ if !pos_dot < 0 && !pos_e >= 0 then begin
+ emit_string (String.sub s 0 !pos_e);
+ emit_string ".0";
+ emit_string (String.sub s !pos_e (String.length s - !pos_e))
+ end else
+ emit_string s
+
+let emit_float_constant (cst, lbl) =
+ `{emit_label lbl} REAL8 {emit_float cst}\n`
+
(* Output the assembly code for an instruction *)
(* Name of current function *)
(* Label of trap for out-of-range accesses *)
let range_check_trap = ref 0
-let float_constants = ref ([] : (int * string) list)
-
let emit_instr i =
match i.desc with
Lend -> ()
| 0xBFF0_0000_0000_0000L -> (* -1.0 *)
` fld1\n fchs\n`
| _ ->
- let lbl = new_label() in
- float_constants := (lbl, s) :: !float_constants;
+ let lbl = add_float_constant s in
` fld {emit_label lbl}\n`
end
| Lop(Iconst_symbol s) ->
let rec emit_all i =
match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next
-(* Emission of the floating-point constants *)
-
-let emit_float s =
- (* MASM doesn't like floating-point constants such as 2e9.
- Turn them into 2.0e9. *)
- let pos_e = ref (-1) and pos_dot = ref (-1) in
- for i = 0 to String.length s - 1 do
- match s.[i] with
- 'e'|'E' -> pos_e := i
- | '.' -> pos_dot := i
- | _ -> ()
- done;
- if !pos_dot < 0 && !pos_e >= 0 then begin
- emit_string (String.sub s 0 !pos_e);
- emit_string ".0";
- emit_string (String.sub s !pos_e (String.length s - !pos_e))
- end else
- emit_string s
-
-let emit_float_constant (lbl, cst) =
- `{emit_label lbl} REAL8 {emit_float cst}\n`
-
(* Emission of a function declaration *)
let fundecl fundecl =
fastcode_flag := fundecl.fun_fast;
tailrec_entry_point := new_label();
stack_offset := 0;
- float_constants := [];
call_gc_sites := [];
bound_error_sites := [];
bound_error_call := 0;
`{emit_label !tailrec_entry_point}:\n`;
emit_all fundecl.fun_body;
List.iter emit_call_gc !call_gc_sites;
- emit_call_bound_errors ();
- begin match !float_constants with
- [] -> ()
- | _ ->
- ` .DATA\n`;
- List.iter emit_float_constant !float_constants;
- float_constants := []
- end
+ emit_call_bound_errors ()
(* Emission of data *)
(* Beginning / end of an assembly file *)
let begin_assembly() =
+ float_constants := [];
`.386\n`;
` .MODEL FLAT\n\n`;
` EXTERN _caml_young_ptr: DWORD\n`;
`{emit_symbol lbl_begin} LABEL DWORD\n`
let end_assembly() =
+ if !float_constants <> [] then begin
+ ` .DATA\n`;
+ List.iter emit_float_constant !float_constants;
+ end;
` .CODE\n`;
let lbl_end = Compilenv.make_symbol (Some "code_end") in
add_def_symbol lbl_end;
(* *)
(***********************************************************************)
-(* $Id: proc.ml 11319 2011-12-16 17:02:48Z xleroy $ *)
-
(* Description of the Intel 386 processor *)
open Misc
Ccomp.command (Config.asm ^ " -o " ^
Filename.quote outfile ^ " " ^ Filename.quote infile)
-open Clflags;;
-open Config;;
+let init () = ()
(* *)
(***********************************************************************)
-(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Cmm
open Arch
open Reg
(* *)
(***********************************************************************)
-(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-open Schedgen (* to create a dependency *)
+let () = let module M = Schedgen in () (* to create a dependency *)
(* Scheduling is turned off because our model does not fit the 486
nor the Pentium very well. In particular, it messes up with the
(* *)
(***********************************************************************)
-(* $Id: selection.ml 12123 2012-02-04 10:00:44Z bmeurer $ *)
-
(* Instruction selection for the Intel x86 *)
open Misc
open Arch
open Proc
open Cmm
-open Reg
open Mach
(* Auxiliary for recognizing addressing modes *)
the result is always left at the top of the floating-point stack *)
| Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
| Ifloatofint | Iload((Single | Double | Double_u), _)
- | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _, _) | Ifloatspecial _) ->
+ | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem _ | Ifloatspecial _) ->
(arg, [| tos |], false) (* don't move it immediately *)
(* For storing a byte, the argument must be in eax...edx.
(But for a short, any reg will do!)
| Caddf ->
self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args
| Csubf ->
- self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args
+ self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev
+ args
| Cmulf ->
self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args
| Cdivf ->
- self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args
+ self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev
+ args
(* Recognize store instructions *)
| Cstore Word ->
begin match args with
(* *)
(***********************************************************************)
-(* $Id: interf.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Construction of the interference graph.
Annotate pseudoregs with interference lists and preference lists. *)
module IntPairSet =
- Set.Make(struct type t = int * int let compare = compare end)
+ Set.Make(struct
+ type t = int * int
+ let compare ((a1,b1) : t) (a2,b2) =
+ match compare a1 a2 with
+ | 0 -> compare b1 b2
+ | c -> c
+ end)
-open Misc
open Reg
open Mach
(* Record an interference between two registers *)
let add_interf ri rj =
- let i = ri.stamp and j = rj.stamp in
- if i <> j then begin
- let p = if i < j then (i, j) else (j, i) in
- if not(IntPairSet.mem p !mat) then begin
- mat := IntPairSet.add p !mat;
- if ri.loc = Unknown then ri.interf <- rj :: ri.interf;
- if rj.loc = Unknown then rj.interf <- ri :: rj.interf
+ if Proc.register_class ri = Proc.register_class rj then begin
+ let i = ri.stamp and j = rj.stamp in
+ if i <> j then begin
+ let p = if i < j then (i, j) else (j, i) in
+ if not(IntPairSet.mem p !mat) then begin
+ mat := IntPairSet.add p !mat;
+ if ri.loc = Unknown then begin
+ ri.interf <- rj :: ri.interf;
+ if not rj.spill then ri.degree <- ri.degree + 1
+ end;
+ if rj.loc = Unknown then begin
+ rj.interf <- ri :: rj.interf;
+ if not ri.spill then rj.degree <- rj.degree + 1
+ end
+ end
end
end in
(* *)
(***********************************************************************)
-(* $Id: interf.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Construction of the interference graph.
Annotate pseudoregs with interference lists and preference lists. *)
(* *)
(***********************************************************************)
-(* $Id: linearize.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Transformation of Mach code into a list of pseudo-instructions. *)
open Reg
(* *)
(***********************************************************************)
-(* $Id: linearize.mli 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Transformation of Mach code into a list of pseudo-instructions. *)
type label = int
(* *)
(***********************************************************************)
-(* $Id: liveness.ml 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Liveness analysis.
Annotate mach code with the set of regs live at each point. *)
(* *)
(***********************************************************************)
-(* $Id: liveness.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Liveness analysis.
Annotate mach code with the set of regs live at each point. *)
(* *)
(***********************************************************************)
-(* $Id: mach.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Representation of machine code by sequences of pseudoinstructions *)
type integer_comparison =
(* *)
(***********************************************************************)
-(* $Id: mach.mli 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Representation of machine code by sequences of pseudoinstructions *)
type integer_comparison =
(* *)
(***********************************************************************)
-(* $Id: arch.ml 12583 2012-06-07 12:19:23Z xleroy $ *)
-
(* Specific operations for the PowerPC processor *)
-open Misc
open Format
(* Machine-specific command-line options *)
let size_int = size_addr
let size_float = 8
+let allow_unaligned_access = false
+
(* Behavior of division *)
let division_crashes_on_overflow = true
(* *)
(***********************************************************************)
-(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Emission of PowerPC assembly code *)
-module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringSet =
+ Set.Make(struct type t = string let compare (x:t) y = compare x y end)
-open Location
open Misc
open Cmm
open Arch
let emit_symbol =
match Config.system with
- | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s)
+ | "elf" | "bsd" | "bsd_elf" -> (fun s -> Emitaux.emit_symbol '.' s)
| "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s)
| _ -> assert false
let label_prefix =
match Config.system with
- | "elf" | "bsd" -> ".L"
+ | "elf" | "bsd" | "bsd_elf" -> ".L"
| "rhapsody" -> "L"
| _ -> assert false
let data_space =
match Config.system with
- | "elf" | "bsd" -> " .section \".data\"\n"
+ | "elf" | "bsd" | "bsd_elf" -> " .section \".data\"\n"
| "rhapsody" -> " .data\n"
| _ -> assert false
let code_space =
match Config.system with
- | "elf" | "bsd" -> " .section \".text\"\n"
+ | "elf" | "bsd" | "bsd_elf" -> " .section \".text\"\n"
| "rhapsody" -> " .text\n"
| _ -> assert false
let rodata_space =
match Config.system with
- | "elf" | "bsd" -> " .section \".rodata\"\n"
+ | "elf" | "bsd" | "bsd_elf" -> " .section \".rodata\"\n"
| "rhapsody" -> " .const\n"
| _ -> assert false
let emit_upper emit_fun arg =
match Config.system with
- | "elf" | "bsd" ->
+ | "elf" | "bsd" | "bsd_elf" ->
emit_fun arg; emit_string "@ha"
| "rhapsody" ->
emit_string "ha16("; emit_fun arg; emit_string ")"
let emit_lower emit_fun arg =
match Config.system with
- | "elf" | "bsd" ->
+ | "elf" | "bsd" | "bsd_elf" ->
emit_fun arg; emit_string "@l"
| "rhapsody" ->
emit_string "lo16("; emit_fun arg; emit_string ")"
match i with
{desc = Lend} -> ()
| {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}}
- when is_simple_instr i & no_interference i.res i.next.arg ->
+ when is_simple_instr i && no_interference i.res i.next.arg ->
emit_instr i.next (Some i);
emit_all i.next.next
| _ ->
else
` .globl {emit_symbol fundecl.fun_name}\n`;
begin match Config.system with
- | "elf" | "bsd" ->
+ | "elf" | "bsd" | "bsd_elf" ->
` .type {emit_symbol fundecl.fun_name}, @function\n`
| _ -> ()
end;
let declare_global_data s =
` .globl {emit_symbol s}\n`;
- if Config.system = "elf" || Config.system = "bsd" then
+ match Config.system with
+ | "elf" | "bsd" | "bsd_elf" ->
` .type {emit_symbol s}, @object\n`
+ | "rhapsody" -> ()
+ | _ -> assert false
let emit_item = function
Cglobal_symbol s ->
(* *)
(***********************************************************************)
-(* $Id: proc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Description of the Power PC *)
open Misc
let loc_external_arguments =
match Config.system with
| "rhapsody" -> poweropen_external_conventions 0 7 100 112
- | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 8
+ | "elf" | "bsd" | "bsd_elf" -> calling_conventions 0 7 100 107 outgoing 8
| _ -> assert false
let extcall_use_push = false
Ccomp.command (Config.asm ^ " -o " ^
Filename.quote outfile ^ " " ^ Filename.quote infile)
-open Clflags;;
-open Config;;
+let init () = ()
(* *)
(***********************************************************************)
-(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Reloading for the PowerPC *)
let fundecl f =
(* *)
(***********************************************************************)
-(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Instruction scheduling for the Power PC *)
open Arch
(* *)
(***********************************************************************)
-(* $Id: selection.ml 12120 2012-02-04 09:43:33Z bmeurer $ *)
-
(* Instruction selection for the Power PC processor *)
-open Misc
open Cmm
-open Reg
open Arch
open Mach
open Format
open Asttypes
open Clambda
-open Debuginfo
let rec pr_idents ppf = function
| [] -> ()
let switch ppf sw =
let spc = ref false in
for i = 0 to Array.length sw.us_index_consts - 1 do
- let n = sw.us_index_consts.(i)
- and l = sw.us_actions_consts.(i) in
+ let n = sw.us_index_consts.(i) in
+ let l = sw.us_actions_consts.(n) in
if !spc then fprintf ppf "@ " else spc := true;
- fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l;
+ fprintf ppf "@[<hv 1>case int %i:@ %a@]" i lam l;
done;
for i = 0 to Array.length sw.us_index_blocks - 1 do
- let n = sw.us_index_blocks.(i)
- and l = sw.us_actions_blocks.(i) in
+ let n = sw.us_index_blocks.(i) in
+ let l = sw.us_actions_blocks.(n) in
if !spc then fprintf ppf "@ " else spc := true;
- fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l;
+ fprintf ppf "@[<hv 1>case tag %i:@ %a@]" i lam l;
done in
fprintf ppf
"@[<1>(switch %a@ @[<v 0>%a@])@]"
let args ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
let kind =
- if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in
+ if k = Lambda.Self then "self"
+ else if k = Lambda.Cached then "cache"
+ else "" in
fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
and sequence ppf ulam = match ulam with
fprintf ppf "%a@ %a" sequence l1 sequence l2
| _ -> lam ppf ulam
-let clambda = lam
+let clambda ppf ulam =
+ fprintf ppf "%a@." lam ulam
(* *)
(***********************************************************************)
-(* $Id: printcmm.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Pretty-printing of C-- code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: printcmm.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Pretty-printing of C-- code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: printlinear.ml 12610 2012-06-17 08:15:25Z xleroy $ *)
-
(* Pretty-printing of linearized machine code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: printlinear.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Pretty-printing of linearized machine code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: printmach.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Pretty-printing of pseudo machine code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: printmach.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Pretty-printing of pseudo machine code *)
open Format
(* *)
(***********************************************************************)
-(* $Id: proc.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Processor descriptions *)
(* Instruction selection *)
(* Calling the assembler *)
val assemble_file: string -> string -> int
+
+(* Called before translating a fundecl. *)
+val init : unit -> unit
(* *)
(***********************************************************************)
-(* $Id: reg.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Cmm
type t =
(* *)
(***********************************************************************)
-(* $Id: reg.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Pseudo-registers *)
type t =
(* *)
(***********************************************************************)
-(* $Id: reload.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
val fundecl: Mach.fundecl -> Mach.fundecl * bool
(* *)
(***********************************************************************)
-(* $Id: reloadgen.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
open Misc
(* *)
(***********************************************************************)
-(* $Id: reloadgen.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
class reload_generic : object
method reload_operation :
Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array
(* *)
(***********************************************************************)
-(* $Id: schedgen.ml 12876 2012-08-24 08:14:30Z xleroy $ *)
-
(* Instruction scheduling *)
-open Misc
open Reg
open Mach
open Linearize
(* *)
(***********************************************************************)
-(* $Id: schedgen.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Instruction scheduling *)
type code_dag_node =
(* *)
(***********************************************************************)
-(* $Id: scheduling.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Instruction scheduling *)
val fundecl: Linearize.fundecl -> Linearize.fundecl
(* *)
(***********************************************************************)
-(* $Id: selectgen.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Selection of pseudo-instructions, assignment of pseudo-registers,
sequentialization. *)
(* *)
(***********************************************************************)
-(* $Id: selectgen.mli 12120 2012-02-04 09:43:33Z bmeurer $ *)
-
(* Selection of pseudo-instructions, assignment of pseudo-registers,
sequentialization. *)
(* *)
(***********************************************************************)
-(* $Id: selection.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Selection of pseudo-instructions, assignment of pseudo-registers,
sequentialization. *)
(* *)
(***********************************************************************)
-(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *)
-
(* Specific operations for the Sparc processor *)
-open Misc
open Format
(* SPARC V8 adds multiply and divide.
let size_int = 4
let size_float = 8
+let allow_unaligned_access = false
+
(* Behavior of division *)
let division_crashes_on_overflow = false
(* *)
(***********************************************************************)
-(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Emission of Sparc assembly code *)
-open Location
open Misc
open Cmm
open Arch
(* *)
(***********************************************************************)
-(* $Id: proc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Description of the Sparc processor *)
open Misc
end in
Ccomp.command (Config.asm ^ asflags ^
Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+let init () = ()
(* *)
(***********************************************************************)
-(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Reloading for the Sparc *)
let fundecl f =
(* *)
(***********************************************************************)
-(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Cmm
open Mach
(* *)
(***********************************************************************)
-(* $Id: selection.ml 12120 2012-02-04 09:43:33Z bmeurer $ *)
-
(* Instruction selection for the Sparc processor *)
-open Misc
open Cmm
open Reg
open Arch
(* *)
(***********************************************************************)
-(* $Id: spill.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Insertion of moves to suggest possible spilling / reloading points
before register allocation. *)
(* *)
(***********************************************************************)
-(* $Id: spill.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Insertion of moves to suggest possible spilling / reloading points
before register allocation. *)
(* *)
(***********************************************************************)
-(* $Id: split.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
(* Renaming of registers at reload points to split live ranges. *)
open Reg
type subst = Reg.t Reg.Map.t
-let subst_reg r sub =
+let subst_reg r (sub : subst) =
try
Reg.Map.find r sub
with Not_found ->
(* *)
(***********************************************************************)
-(* $Id: split.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Renaming of registers at reload points to split live ranges. *)
val fundecl: Mach.fundecl -> Mach.fundecl
../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \
- ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \
+ ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \
../byterun/fail.h
obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \
- ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h
+ ../byterun/printexc.h stack.h ../byterun/sys.h
str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h
+ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \
+ ../byterun/int64_native.h
sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \
../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \
- ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \
+ ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \
../byterun/fail.h
obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \
- ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h
+ ../byterun/printexc.h stack.h ../byterun/sys.h
str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h
+ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \
+ ../byterun/int64_native.h
sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \
../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \
- ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \
+ ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \
../byterun/fail.h
obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \
- ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h
+ ../byterun/printexc.h stack.h ../byterun/sys.h
str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h
+ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \
+ ../byterun/int64_native.h
sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \
# #
#########################################################################
-# $Id: Makefile 12477 2012-05-24 16:17:19Z xleroy $
-
include ../config/Makefile
CC=$(NATIVECC)
cp libasmrunp.a $(LIBDIR)/libasmrunp.a
cd $(LIBDIR); $(RANLIB) libasmrunp.a
+power-bsd_elf.S: power-elf.S
+ cp power-elf.S power-bsd_elf.S
+
power.o: power-$(SYSTEM).o
cp power-$(SYSTEM).o power.o
.SUFFIXES: .S .d.o .p.o
.S.o:
- $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.S || \
- { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; }
+ $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S || \
+ { echo "If your assembler produced syntax errors, it is probably";\
+ echo "unhappy with the preprocessor. Check your assembler, or";\
+ echo "try producing $*.o by hand.";\
+ exit 2; }
.S.p.o:
$(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S
# #
#########################################################################
-# $Id: Makefile.nt 12495 2012-05-29 10:41:01Z lefessan $
-
include ../config/Makefile
CC=$(NATIVECC)
-CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(NATIVECCCOMPOPTS)
+CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) \
+ $(NATIVECCCOMPOPTS)
-COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) \
+COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O)\
misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \
compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \
intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \
$(ASM)amd64nt.obj amd64nt.asm
i386.o: i386.S
- $(CC) -c -DSYS_$(SYSTEM) i386.S
+ $(ASPP) -DSYS_$(SYSTEM) i386.S
amd64.o: amd64.S
- $(CC) -c -DSYS_$(SYSTEM) amd64.S
+ $(ASPP) -DSYS_$(SYSTEM) amd64.S
install:
cp libasmrun.$(A) $(LIBDIR)
/* */
/***********************************************************************/
-/* $Id: amd64.S 12907 2012-09-08 16:51:03Z xleroy $ */
-
/* Asm part of the runtime system, AMD64 processor */
/* Must be preprocessed by cpp */
#define CFI_ADJUST(n)
#endif
+#ifdef WITH_FRAME_POINTERS
+
+#define ENTER_FUNCTION \
+ pushq %rbp; CFI_ADJUST(8); \
+ movq %rsp, %rbp
+#define LEAVE_FUNCTION \
+ popq %rbp; CFI_ADJUST(-8);
+
+#else
+
+#define ENTER_FUNCTION \
+ subq $8, %rsp; CFI_ADJUST (8);
+#define LEAVE_FUNCTION \
+ addq $8, %rsp; CFI_ADJUST (-8);
+
+#endif
+
#if defined(__PIC__) && !defined(SYS_mingw64)
/* Position-independent operations on global variables. */
/* Push global [label] on stack. Clobbers %r11. */
#define PUSH_VAR(srclabel) \
movq GREL(srclabel)(%rip), %r11 ; \
- pushq (%r11)
+ pushq (%r11); CFI_ADJUST (8)
/* Pop global [label] off stack. Clobbers %r11. */
#define POP_VAR(dstlabel) \
movq GREL(dstlabel)(%rip), %r11 ; \
- popq (%r11)
+ popq (%r11); CFI_ADJUST (-8)
/* Record lowest stack address and return address. Clobbers %rax. */
#define RECORD_STACK_FRAME(OFFSET) \
- pushq %r11 ; \
+ pushq %r11 ; CFI_ADJUST(8); \
movq 8+OFFSET(%rsp), %rax ; \
STORE_VAR(%rax,caml_last_return_address) ; \
leaq 16+OFFSET(%rsp), %rax ; \
STORE_VAR(%rax,caml_bottom_of_stack) ; \
- popq %r11
+ popq %r11; CFI_ADJUST(-8)
+
+/* Load address of global [label] in register [dst]. */
+#define LEA_VAR(label,dst) \
+ movq GREL(label)(%rip), dst
#else
testl imm, G(label)(%rip)
#define PUSH_VAR(srclabel) \
- pushq G(srclabel)(%rip)
+ pushq G(srclabel)(%rip) ; CFI_ADJUST(8)
#define POP_VAR(dstlabel) \
- popq G(dstlabel)(%rip)
+ popq G(dstlabel)(%rip); CFI_ADJUST(-8)
#define RECORD_STACK_FRAME(OFFSET) \
movq OFFSET(%rsp), %rax ; \
leaq 8+OFFSET(%rsp), %rax ; \
STORE_VAR(%rax,caml_bottom_of_stack)
+#define LEA_VAR(label,dst) \
+ leaq G(label)(%rip), dst
#endif
/* Save and restore all callee-save registers on stack.
/* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */
#define PUSH_CALLEE_SAVE_REGS \
- pushq %rbx; \
- pushq %rbp; \
- pushq %rsi; \
- pushq %rdi; \
- pushq %r12; \
- pushq %r13; \
- pushq %r14; \
- pushq %r15; \
- subq $(8+10*16), %rsp; \
+ pushq %rbx; CFI_ADJUST (8); \
+ pushq %rbp; CFI_ADJUST (8); \
+ pushq %rsi; CFI_ADJUST (8); \
+ pushq %rdi; CFI_ADJUST (8); \
+ pushq %r12; CFI_ADJUST (8); \
+ pushq %r13; CFI_ADJUST (8); \
+ pushq %r14; CFI_ADJUST (8); \
+ pushq %r15; CFI_ADJUST (8); \
+ subq $(8+10*16), %rsp; CFI_ADJUST (8+10*16); \
movupd %xmm6, 0*16(%rsp); \
movupd %xmm7, 1*16(%rsp); \
movupd %xmm8, 2*16(%rsp); \
movupd 7*16(%rsp), %xmm13; \
movupd 8*16(%rsp), %xmm14; \
movupd 9*16(%rsp), %xmm15; \
- addq $(8+10*16), %rsp; \
- popq %r15; \
- popq %r14; \
- popq %r13; \
- popq %r12; \
- popq %rdi; \
- popq %rsi; \
- popq %rbp; \
- popq %rbx
+ addq $(8+10*16), %rsp; CFI_ADJUST (-8-10*16); \
+ popq %r15; CFI_ADJUST(-8); \
+ popq %r14; CFI_ADJUST(-8); \
+ popq %r13; CFI_ADJUST(-8); \
+ popq %r12; CFI_ADJUST(-8); \
+ popq %rdi; CFI_ADJUST(-8); \
+ popq %rsi; CFI_ADJUST(-8); \
+ popq %rbp; CFI_ADJUST(-8); \
+ popq %rbx; CFI_ADJUST(-8)
#else
/* Unix API: callee-save regs are rbx, rbp, r12-r15 */
#define PUSH_CALLEE_SAVE_REGS \
- pushq %rbx; \
- pushq %rbp; \
- pushq %r12; \
- pushq %r13; \
- pushq %r14; \
- pushq %r15; \
- subq $8, %rsp
+ pushq %rbx; CFI_ADJUST(8); \
+ pushq %rbp; CFI_ADJUST(8); \
+ pushq %r12; CFI_ADJUST(8); \
+ pushq %r13; CFI_ADJUST(8); \
+ pushq %r14; CFI_ADJUST(8); \
+ pushq %r15; CFI_ADJUST(8); \
+ subq $8, %rsp; CFI_ADJUST(8)
#define POP_CALLEE_SAVE_REGS \
- addq $8, %rsp; \
- popq %r15; \
- popq %r14; \
- popq %r13; \
- popq %r12; \
- popq %rbp; \
- popq %rbx
+ addq $8, %rsp; CFI_ADJUST(-8); \
+ popq %r15; CFI_ADJUST(-8); \
+ popq %r14; CFI_ADJUST(-8); \
+ popq %r13; CFI_ADJUST(-8); \
+ popq %r12; CFI_ADJUST(-8); \
+ popq %rbp; CFI_ADJUST(-8); \
+ popq %rbx; CFI_ADJUST(-8);
#endif
#ifdef SYS_mingw64
/* Calls from OCaml to C must reserve 32 bytes of extra stack space */
-# define PREPARE_FOR_C_CALL subq $32, %rsp
-# define CLEANUP_AFTER_C_CALL addq $32, %rsp
+# define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32)
+# define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32)
#else
# define PREPARE_FOR_C_CALL
# define CLEANUP_AFTER_C_CALL
.globl G(caml_system__code_begin)
G(caml_system__code_begin):
+ ret /* just one instruction, so that debuggers don't display
+ caml_system__code_begin instead of caml_call_gc */
/* Allocation */
addq $32768, %rsp
#endif
/* Build array of registers, save it into caml_gc_regs */
- pushq %r11
- pushq %r10
- pushq %rbp
- pushq %r13
- pushq %r12
- pushq %r9
- pushq %r8
- pushq %rcx
- pushq %rdx
- pushq %rsi
- pushq %rdi
- pushq %rbx
- pushq %rax
+#ifdef WITH_FRAME_POINTERS
+ ENTER_FUNCTION ;
+#else
+ pushq %rbp; CFI_ADJUST(8);
+#endif
+ pushq %r11; CFI_ADJUST (8);
+ pushq %r10; CFI_ADJUST (8);
+ pushq %r13; CFI_ADJUST (8);
+ pushq %r12; CFI_ADJUST (8);
+ pushq %r9; CFI_ADJUST (8);
+ pushq %r8; CFI_ADJUST (8);
+ pushq %rcx; CFI_ADJUST (8);
+ pushq %rdx; CFI_ADJUST (8);
+ pushq %rsi; CFI_ADJUST (8);
+ pushq %rdi; CFI_ADJUST (8);
+ pushq %rbx; CFI_ADJUST (8);
+ pushq %rax; CFI_ADJUST (8);
STORE_VAR(%rsp, caml_gc_regs)
/* Save caml_young_ptr, caml_exception_pointer */
STORE_VAR(%r15, caml_young_ptr)
STORE_VAR(%r14, caml_exception_pointer)
/* Save floating-point registers */
- subq $(16*8), %rsp
- CFI_ADJUST(232)
+ subq $(16*8), %rsp; CFI_ADJUST (16*8);
movsd %xmm0, 0*8(%rsp)
movsd %xmm1, 1*8(%rsp)
movsd %xmm2, 2*8(%rsp)
movsd 13*8(%rsp), %xmm13
movsd 14*8(%rsp), %xmm14
movsd 15*8(%rsp), %xmm15
- addq $(16*8), %rsp
- popq %rax
- popq %rbx
- popq %rdi
- popq %rsi
- popq %rdx
- popq %rcx
- popq %r8
- popq %r9
- popq %r12
- popq %r13
- popq %rbp
- popq %r10
- popq %r11
- CFI_ADJUST(-232)
+ addq $(16*8), %rsp; CFI_ADJUST(-16*8)
+ popq %rax; CFI_ADJUST(-8)
+ popq %rbx; CFI_ADJUST(-8)
+ popq %rdi; CFI_ADJUST(-8)
+ popq %rsi; CFI_ADJUST(-8)
+ popq %rdx; CFI_ADJUST(-8)
+ popq %rcx; CFI_ADJUST(-8)
+ popq %r8; CFI_ADJUST(-8)
+ popq %r9; CFI_ADJUST(-8)
+ popq %r12; CFI_ADJUST(-8)
+ popq %r13; CFI_ADJUST(-8)
+ popq %r10; CFI_ADJUST(-8)
+ popq %r11; CFI_ADJUST(-8)
+#ifdef WITH_FRAME_POINTERS
+ LEAVE_FUNCTION
+#else
+ popq %rbp; CFI_ADJUST(-8);
+#endif
/* Return to caller */
ret
- CFI_ENDPROC
+CFI_ENDPROC
FUNCTION(G(caml_alloc1))
+CFI_STARTPROC
LBL(caml_alloc1):
subq $16, %r15
CMP_VAR(caml_young_limit, %r15)
ret
LBL(100):
RECORD_STACK_FRAME(0)
- subq $8, %rsp
+ ENTER_FUNCTION
+/* subq $8, %rsp; CFI_ADJUST (8); */
call LBL(caml_call_gc)
- addq $8, %rsp
+/* addq $8, %rsp; CFI_ADJUST (-8); */
+ LEAVE_FUNCTION
jmp LBL(caml_alloc1)
+CFI_ENDPROC
FUNCTION(G(caml_alloc2))
+CFI_STARTPROC
LBL(caml_alloc2):
subq $24, %r15
CMP_VAR(caml_young_limit, %r15)
ret
LBL(101):
RECORD_STACK_FRAME(0)
- subq $8, %rsp
+ ENTER_FUNCTION
+/* subq $8, %rsp; CFI_ADJUST (8); */
call LBL(caml_call_gc)
- addq $8, %rsp
+/* addq $8, %rsp; CFI_ADJUST (-8); */
+ LEAVE_FUNCTION
jmp LBL(caml_alloc2)
+CFI_ENDPROC
FUNCTION(G(caml_alloc3))
+CFI_STARTPROC
LBL(caml_alloc3):
subq $32, %r15
CMP_VAR(caml_young_limit, %r15)
ret
LBL(102):
RECORD_STACK_FRAME(0)
- subq $8, %rsp
+ ENTER_FUNCTION
+/* subq $8, %rsp; CFI_ADJUST (8) */
call LBL(caml_call_gc)
- addq $8, %rsp
+/* addq $8, %rsp; CFI_ADJUST (-8) */
+ LEAVE_FUNCTION
jmp LBL(caml_alloc3)
+CFI_ENDPROC
FUNCTION(G(caml_allocN))
+CFI_STARTPROC
LBL(caml_allocN):
- pushq %rax /* save desired size */
+ pushq %rax; CFI_ADJUST(8) /* save desired size */
subq %rax, %r15
CMP_VAR(caml_young_limit, %r15)
jb LBL(103)
- addq $8, %rsp /* drop desired size */
+ addq $8, %rsp; CFI_ADJUST (-8) /* drop desired size */
ret
LBL(103):
RECORD_STACK_FRAME(8)
+#ifdef WITH_FRAME_POINTERS
+ /* Do we need 16-byte alignment here ? */
+ ENTER_FUNCTION
+#endif
call LBL(caml_call_gc)
- popq %rax /* recover desired size */
+#ifdef WITH_FRAME_POINTERS
+ LEAVE_FUNCTION
+#endif
+ popq %rax; CFI_ADJUST(-8) /* recover desired size */
jmp LBL(caml_allocN)
+CFI_ENDPROC
/* Call a C function from OCaml */
FUNCTION(G(caml_c_call))
+CFI_STARTPROC
LBL(caml_c_call):
/* Record lowest stack address and return address */
- popq %r12
+ popq %r12; CFI_ADJUST(-8)
STORE_VAR(%r12, caml_last_return_address)
STORE_VAR(%rsp, caml_bottom_of_stack)
- pushq %r12
+ subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */
#ifndef SYS_mingw64
/* Touch the stack to trigger a recoverable segfault
if insufficient space remains */
/* No need to PREPARE_FOR_C_CALL since the caller already
reserved the stack space if needed (cf. amd64/proc.ml) */
jmp *%rax
+CFI_ENDPROC
/* Start the OCaml program */
FUNCTION(G(caml_start_program))
- CFI_STARTPROC
+ CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
- CFI_ADJUST(56)
/* Initial entry point is G(caml_program) */
leaq GCALL(caml_program)(%rip), %r12
/* Common code for caml_start_program and caml_callback* */
LBL(caml_start_program):
/* Build a callback link */
- subq $8, %rsp /* stack 16-aligned */
+ subq $8, %rsp; CFI_ADJUST (8) /* stack 16-aligned */
PUSH_VAR(caml_gc_regs)
PUSH_VAR(caml_last_return_address)
PUSH_VAR(caml_bottom_of_stack)
- CFI_ADJUST(32)
/* Setup alloc ptr and exception ptr */
LOAD_VAR(caml_young_ptr, %r15)
LOAD_VAR(caml_exception_pointer, %r14)
/* Build an exception handler */
lea LBL(108)(%rip), %r13
- pushq %r13
- pushq %r14
+ pushq %r13; CFI_ADJUST(8)
+ pushq %r14; CFI_ADJUST(8)
CFI_ADJUST(16)
movq %rsp, %r14
/* Call the OCaml code */
call *%r12
LBL(107):
/* Pop the exception handler */
- popq %r14
- popq %r12 /* dummy register */
+ popq %r14; CFI_ADJUST(-8)
+ popq %r12; CFI_ADJUST(-8) /* dummy register */
CFI_ADJUST(-16)
LBL(109):
/* Update alloc ptr and exception ptr */
POP_VAR(caml_bottom_of_stack)
POP_VAR(caml_last_return_address)
POP_VAR(caml_gc_regs)
- addq $8, %rsp
+ addq $8, %rsp; CFI_ADJUST (-8);
/* Restore callee-save registers. */
POP_CALLEE_SAVE_REGS
/* Return to caller. */
/* Mark the bucket as an exception result and return it */
orq $2, %rax
jmp LBL(109)
- CFI_ENDPROC
+CFI_ENDPROC
/* Registers holding arguments of C functions. */
/* Raise an exception from OCaml */
FUNCTION(G(caml_raise_exn))
+CFI_STARTPROC
TESTL_VAR($1, caml_backtrace_active)
jne LBL(110)
movq %r14, %rsp
LBL(110):
movq %rax, %r12 /* Save exception bucket */
movq %rax, C_ARG_1 /* arg 1: exception bucket */
+#ifdef WITH_FRAME_POINTERS
+ ENTER_FUNCTION
+ movq 8(%rsp), C_ARG_2 /* arg 2: pc of raise */
+ leaq 16(%rsp), C_ARG_3 /* arg 3: sp at raise */
+#else
popq C_ARG_2 /* arg 2: pc of raise */
movq %rsp, C_ARG_3 /* arg 3: sp at raise */
+#endif
movq %r14, C_ARG_4 /* arg 4: sp of handler */
- /* PR#5700: thanks to popq above, stack is now 16-aligned */
+ /* PR#5700: thanks to popq above, stack is now 16-aligned */
+ /* Thanks to ENTER_FUNCTION, stack is now 16-aligned */
PREPARE_FOR_C_CALL /* no need to cleanup after */
call GCALL(caml_stash_backtrace)
movq %r12, %rax /* Recover exception bucket */
movq %r14, %rsp
popq %r14
ret
+CFI_ENDPROC
/* Raise an exception from C */
FUNCTION(G(caml_raise_exception))
+CFI_STARTPROC
TESTL_VAR($1, caml_backtrace_active)
jne LBL(111)
movq C_ARG_1, %rax
LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */
- popq %r14 /* Recover previous exception handler */
+ popq %r14 /* Recover previous exception handler */
LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */
ret
LBL(111):
+#ifdef WITH_FRAME_POINTERS
+ ENTER_FUNCTION ;
+#endif
movq C_ARG_1, %r12 /* Save exception bucket */
/* arg 1: exception bucket */
LOAD_VAR(caml_last_return_address,C_ARG_2) /* arg 2: pc of raise */
LOAD_VAR(caml_bottom_of_stack,C_ARG_3) /* arg 3: sp of raise */
LOAD_VAR(caml_exception_pointer,C_ARG_4) /* arg 4: sp of handler */
+#ifndef WITH_FRAME_POINTERS
subq $8, %rsp /* PR#5700: maintain stack alignment */
+#endif
PREPARE_FOR_C_CALL /* no need to cleanup after */
call GCALL(caml_stash_backtrace)
movq %r12, %rax /* Recover exception bucket */
LOAD_VAR(caml_exception_pointer,%rsp)
popq %r14 /* Recover previous exception handler */
- LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
+ LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
ret
+CFI_ENDPROC
+
+/* Raise a Stack_overflow exception on return from segv_handler()
+ (in asmrun/signals_asm.c). On entry, the stack is full, so we
+ cannot record a backtrace.
+ No CFI information here since this function disrupts the stack
+ backtrace anyway. */
+
+FUNCTION(G(caml_stack_overflow))
+ LEA_VAR(caml_bucket_Stack_overflow, %rax)
+ movq %r14, %rsp /* cut the stack */
+ popq %r14 /* recover previous exn handler */
+ ret /* jump to handler's code */
/* Callback from C to OCaml */
FUNCTION(G(caml_callback_exn))
+CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Initial loading of arguments */
movq C_ARG_2, %rax /* argument */
movq 0(%rbx), %r12 /* code pointer */
jmp LBL(caml_start_program)
+CFI_ENDPROC
FUNCTION(G(caml_callback2_exn))
+CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Initial loading of arguments */
movq C_ARG_3, %rbx /* second argument */
leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */
jmp LBL(caml_start_program)
+CFI_ENDPROC
FUNCTION(G(caml_callback3_exn))
+CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Initial loading of arguments */
movq C_ARG_4, %rdi /* third argument */
leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */
jmp LBL(caml_start_program)
+CFI_ENDPROC
FUNCTION(G(caml_ml_array_bound_error))
+CFI_STARTPROC
leaq GCALL(caml_array_bound_error)(%rip), %rax
jmp LBL(caml_c_call)
+CFI_ENDPROC
.globl G(caml_system__code_end)
G(caml_system__code_end):
;* *
;***********************************************************************
-; $Id: amd64nt.asm 12907 2012-09-08 16:51:03Z xleroy $
-
; Asm part of the runtime system, AMD64 processor, Intel syntax
; Notes on Win64 calling conventions:
mov caml_young_ptr, r15
mov caml_exception_pointer, r14
; Build array of registers, save it into caml_gc_regs
+ push rbp
push r11
push r10
- push rbp
push r13
push r12
push r9
pop r9
pop r12
pop r13
- pop rbp
pop r10
pop r11
+ pop rbp
; Restore caml_young_ptr, caml_exception_pointer
mov r15, caml_young_ptr
mov r14, caml_exception_pointer
/* */
/***********************************************************************/
-/* $Id: arm.S 12800 2012-07-30 18:59:07Z doligez $ */
-
/* Asm part of the runtime system, ARM processor */
/* Must be preprocessed by cpp */
.syntax unified
.text
-#if defined(SYS_linux_eabihf)
+#if defined(SYS_linux_eabihf) && defined(MODEL_armv6)
+ .arch armv6
+ .fpu vfpv2
+ .arm
+
+ /* Compatibility macros */
+ .macro cbz reg, lbl
+ cmp \reg, #0
+ beq \lbl
+ .endm
+#elif defined(SYS_linux_eabihf)
.arch armv7-a
.fpu vfpv3-d16
.thumb
cmp \reg, #0
beq \lbl
.endm
- .macro vpop regs
- .endm
- .macro vpush regs
- .endm
#endif
trap_ptr .req r8
alloc_ptr .req r10
alloc_limit .req r11
+/* Support for CFI directives */
+
+#if defined(ASM_CFI_SUPPORTED)
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
/* Support for profiling with gprof */
#if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi))
#define PROFILE \
- push {lr}; \
- bl __gnu_mcount_nc
+ push {lr}; CFI_ADJUST(4); \
+ bl __gnu_mcount_nc; CFI_ADJUST(-4)
#else
#define PROFILE
#endif
.align 2
.globl caml_call_gc
- .type caml_call_gc, %function
caml_call_gc:
+ CFI_STARTPROC
PROFILE
/* Record return address */
ldr r12, =caml_last_return_address
/* Record lowest stack address */
ldr r12, =caml_bottom_of_stack
str sp, [r12]
+#if defined(SYS_linux_eabihf)
/* Save caller floating-point registers on the stack */
- vpush {d0-d7}
+ vpush {d0-d7}; CFI_ADJUST(64)
+#endif
/* Save integer registers and return address on the stack */
- push {r0-r7,r12,lr}
+ push {r0-r7,r12,lr}; CFI_ADJUST(40)
/* Store pointer to saved integer registers in caml_gc_regs */
ldr r12, =caml_gc_regs
str sp, [r12]
/* Call the garbage collector */
bl caml_garbage_collection
/* Restore integer registers and return address from the stack */
- pop {r0-r7,r12,lr}
+ pop {r0-r7,r12,lr}; CFI_ADJUST(-40)
+#if defined(SYS_linux_eabihf)
/* Restore floating-point registers from the stack */
- vpop {d0-d7}
+ vpop {d0-d7}; CFI_ADJUST(-64)
+#endif
/* Reload new allocation pointer and limit */
/* alloc_limit still points to caml_young_ptr */
ldr r12, =caml_young_limit
ldr alloc_limit, [r12]
/* Return to caller */
bx lr
+ CFI_ENDPROC
.type caml_call_gc, %function
.size caml_call_gc, .-caml_call_gc
.align 2
.globl caml_alloc1
- .type caml_alloc1, %function
caml_alloc1:
+ CFI_STARTPROC
PROFILE
.Lcaml_alloc1:
sub alloc_ptr, alloc_ptr, 8
ldr lr, [r7]
/* Try again */
b .Lcaml_alloc1
+ CFI_ENDPROC
.type caml_alloc1, %function
.size caml_alloc1, .-caml_alloc1
.align 2
.globl caml_alloc2
- .type caml_alloc2, %function
caml_alloc2:
+ CFI_STARTPROC
PROFILE
.Lcaml_alloc2:
sub alloc_ptr, alloc_ptr, 12
ldr lr, [r7]
/* Try again */
b .Lcaml_alloc2
+ CFI_ENDPROC
.type caml_alloc2, %function
.size caml_alloc2, .-caml_alloc2
.globl caml_alloc3
.type caml_alloc3, %function
caml_alloc3:
+ CFI_STARTPROC
PROFILE
.Lcaml_alloc3:
sub alloc_ptr, alloc_ptr, 16
ldr lr, [r7]
/* Try again */
b .Lcaml_alloc3
+ CFI_ENDPROC
.type caml_alloc3, %function
.size caml_alloc3, .-caml_alloc3
.align 2
.globl caml_allocN
- .type caml_allocN, %function
caml_allocN:
+ CFI_STARTPROC
PROFILE
.Lcaml_allocN:
sub alloc_ptr, alloc_ptr, r7
ldr lr, [r12]
/* Try again */
b .Lcaml_allocN
+ CFI_ENDPROC
.type caml_allocN, %function
.size caml_allocN, .-caml_allocN
.align 2
.globl caml_c_call
- .type caml_c_call, %function
caml_c_call:
+ CFI_STARTPROC
PROFILE
/* Record lowest stack address and return address */
ldr r5, =caml_last_return_address
ldr alloc_limit, [r6]
/* Return */
bx r4
+ CFI_ENDPROC
.type caml_c_call, %function
.size caml_c_call, .-caml_c_call
.align 2
.globl caml_start_program
- .type caml_start_program, %function
caml_start_program:
+ CFI_STARTPROC
PROFILE
ldr r12, =caml_program
/* Arguments to the OCaml code are in r0...r3 */
.Ljump_to_caml:
+#if defined(SYS_linux_eabihf)
+ /* Save callee-save floating-point registers */
+ vpush {d8-d15}; CFI_ADJUST(64)
+#endif
/* Save return address and callee-save registers */
- vpush {d8-d15}
- push {r4-r8,r10,r11,lr} /* 8-byte alignment */
+ push {r4-r8,r10,r11,lr}; CFI_ADJUST(32) /* 8-byte alignment */
/* Setup a callback link on the stack */
- sub sp, sp, 4*4 /* 8-byte alignment */
+ sub sp, sp, 16; CFI_ADJUST(16) /* 8-byte alignment */
ldr r4, =caml_bottom_of_stack
ldr r5, =caml_last_return_address
ldr r6, =caml_gc_regs
str r5, [sp, 4]
str r6, [sp, 8]
/* Setup a trap frame to catch exceptions escaping the OCaml code */
- sub sp, sp, 2*4
+ sub sp, sp, 8; CFI_ADJUST(8)
ldr r6, =caml_exception_pointer
ldr r5, =.Ltrap_handler
ldr r4, [r6]
ldr r4, =caml_exception_pointer
ldr r5, [sp, 0]
str r5, [r4]
- add sp, sp, 2*4
+ add sp, sp, 8; CFI_ADJUST(-8)
/* Pop the callback link, restoring the global variables */
.Lreturn_result:
ldr r4, =caml_bottom_of_stack
ldr r4, =caml_gc_regs
ldr r5, [sp, 8]
str r5, [r4]
- add sp, sp, 4*4
+ add sp, sp, 16; CFI_ADJUST(-16)
/* Update allocation pointer */
ldr r4, =caml_young_ptr
str alloc_ptr, [r4]
- /* Reload callee-save registers and return */
- pop {r4-r8,r10,r11,lr}
- vpop {d8-d15}
+ /* Reload callee-save registers and return address */
+ pop {r4-r8,r10,r11,lr}; CFI_ADJUST(-32)
+#if defined(SYS_linux_eabihf)
+ /* Reload callee-save floating-point registers */
+ vpop {d8-d15}; CFI_ADJUST(-64)
+#endif
bx lr
+ CFI_ENDPROC
.type .Lcaml_retaddr, %function
.size .Lcaml_retaddr, .-.Lcaml_retaddr
.type caml_start_program, %function
.align 2
.Ltrap_handler:
+ CFI_STARTPROC
/* Save exception pointer */
ldr r12, =caml_exception_pointer
str trap_ptr, [r12]
orr r0, r0, 2
/* Return it */
b .Lreturn_result
+ CFI_ENDPROC
.type .Ltrap_handler, %function
.size .Ltrap_handler, .-.Ltrap_handler
.align 2
.globl caml_raise_exn
caml_raise_exn:
+ CFI_STARTPROC
PROFILE
/* Test if backtrace is active */
ldr r1, =caml_backtrace_active
mov sp, trap_ptr
/* Pop previous handler and addr of trap, and jump to it */
pop {trap_ptr, pc}
+ CFI_ENDPROC
.type caml_raise_exn, %function
.size caml_raise_exn, .-caml_raise_exn
.align 2
.globl caml_raise_exception
- .type caml_raise_exception, %function
caml_raise_exception:
+ CFI_STARTPROC
PROFILE
/* Reload trap ptr, alloc ptr and alloc limit */
ldr trap_ptr, =caml_exception_pointer
mov sp, trap_ptr
/* Pop previous handler and addr of trap, and jump to it */
pop {trap_ptr, pc}
+ CFI_ENDPROC
.type caml_raise_exception, %function
.size caml_raise_exception, .-caml_raise_exception
.align 2
.globl caml_callback_exn
- .type caml_callback_exn, %function
caml_callback_exn:
+ CFI_STARTPROC
PROFILE
/* Initial shuffling of arguments (r0 = closure, r1 = first arg) */
mov r12, r0
mov r1, r12 /* r1 = closure environment */
ldr r12, [r12] /* code pointer */
b .Ljump_to_caml
+ CFI_ENDPROC
.type caml_callback_exn, %function
.size caml_callback_exn, .-caml_callback_exn
.align 2
.globl caml_callback2_exn
- .type caml_callback2_exn, %function
caml_callback2_exn:
+ CFI_STARTPROC
PROFILE
/* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */
mov r12, r0
mov r2, r12 /* r2 = closure environment */
ldr r12, =caml_apply2
b .Ljump_to_caml
+ CFI_ENDPROC
.type caml_callback2_exn, %function
.size caml_callback2_exn, .-caml_callback2_exn
.align 2
.globl caml_callback3_exn
- .type caml_callback3_exn, %function
caml_callback3_exn:
+ CFI_STARTPROC
PROFILE
/* Initial shuffling of arguments */
/* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */
mov r3, r12 /* r3 = closure environment */
ldr r12, =caml_apply3
b .Ljump_to_caml
+ CFI_ENDPROC
.type caml_callback3_exn, %function
.size caml_callback3_exn, .-caml_callback3_exn
.align 2
.globl caml_ml_array_bound_error
- .type caml_ml_array_bound_error, %function
caml_ml_array_bound_error:
+ CFI_STARTPROC
PROFILE
/* Load address of [caml_array_bound_error] in r7 */
ldr r7, =caml_array_bound_error
/* Call that function */
b caml_c_call
+ CFI_ENDPROC
.type caml_ml_array_bound_error, %function
.size caml_ml_array_bound_error, .-caml_ml_array_bound_error
/* */
/***********************************************************************/
-/* $Id: backtrace.c 12149 2012-02-10 16:15:24Z doligez $ */
-
/* Stack backtrace for uncaught exceptions */
#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
#include "alloc.h"
#include "backtrace.h"
#include "memory.h"
return Val_bool(caml_backtrace_active);
}
-/* Store the return addresses contained in the given stack fragment
- into the backtrace array */
+/* returns the next frame descriptor (or NULL if none is available),
+ and updates *pc and *sp to point to the following one. */
-void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
{
frame_descr * d;
uintnat h;
- if (exn != caml_backtrace_last_exn) {
- caml_backtrace_pos = 0;
- caml_backtrace_last_exn = exn;
- }
- if (caml_backtrace_buffer == NULL) {
- caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
- if (caml_backtrace_buffer == NULL) return;
- }
if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
while (1) {
- /* Find the descriptor corresponding to the return address */
- h = Hash_retaddr(pc);
- while(1) {
+ h = Hash_retaddr(*pc);
+ while (1) {
d = caml_frame_descriptors[h];
- if (d == 0) return; /* can happen if some code not compiled with -g */
- if (d->retaddr == pc) break;
+ if (d == 0) return NULL; /* can happen if some code compiled without -g */
+ if (d->retaddr == *pc) break;
h = (h+1) & caml_frame_descriptors_mask;
}
/* Skip to next frame */
if (d->frame_size != 0xFFFF) {
- /* Regular frame, store its descriptor in the backtrace buffer */
- if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
- caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d;
+ /* Regular frame, update sp/pc and return the frame descriptor */
#ifndef Stack_grows_upwards
- sp += (d->frame_size & 0xFFFC);
+ *sp += (d->frame_size & 0xFFFC);
#else
- sp -= (d->frame_size & 0xFFFC);
+ *sp -= (d->frame_size & 0xFFFC);
#endif
- pc = Saved_return_address(sp);
+ *pc = Saved_return_address(*sp);
#ifdef Mask_already_scanned
- pc = Mask_already_scanned(pc);
+ *pc = Mask_already_scanned(*pc);
#endif
+ return d;
} else {
/* Special frame marking the top of a stack chunk for an ML callback.
Skip C portion of stack and continue with next ML stack chunk. */
- struct caml_context * next_context = Callback_link(sp);
- sp = next_context->bottom_of_stack;
- pc = next_context->last_retaddr;
+ struct caml_context * next_context = Callback_link(*sp);
+ *sp = next_context->bottom_of_stack;
+ *pc = next_context->last_retaddr;
/* A null sp means no more ML stack chunks; stop here. */
- if (sp == NULL) return;
+ if (*sp == NULL) return NULL;
}
+ }
+}
+
+/* Stores the return addresses contained in the given stack fragment
+ into the backtrace array ; this version is performance-sensitive as
+ it is called at each [raise] in a program compiled with [-g], so we
+ preserved the global, statically bounded buffer of the old
+ implementation -- before the more flexible
+ [caml_get_current_callstack] was implemented. */
+
+void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+{
+ if (exn != caml_backtrace_last_exn) {
+ caml_backtrace_pos = 0;
+ caml_backtrace_last_exn = exn;
+ }
+ if (caml_backtrace_buffer == NULL) {
+ caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+ if (caml_backtrace_buffer == NULL) return;
+ }
+
+ /* iterate on each frame */
+ while (1) {
+ frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+ if (descr == NULL) return;
+ /* store its descriptor in the backtrace buffer */
+ if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
+ caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) descr;
+
/* Stop when we reach the current exception handler */
#ifndef Stack_grows_upwards
if (sp > trapsp) return;
}
}
+/* Stores upto [max_frames_value] frames of the current call stack to
+ return to the user. This is used not in an exception-raising
+ context, but only when the user requests to save the trace
+ (hopefully less often). Instead of using a bounded buffer as
+ [caml_stash_backtrace], we first traverse the stack to compute the
+ right size, then allocate space for the trace. */
+
+CAMLprim value caml_get_current_callstack(value max_frames_value) {
+ CAMLparam1(max_frames_value);
+ CAMLlocal1(trace);
+
+ /* we use `intnat` here because, were it only `int`, passing `max_int`
+ from the OCaml side would overflow on 64bits machines. */
+ intnat max_frames = Long_val(max_frames_value);
+ intnat trace_size;
+
+ /* first compute the size of the trace */
+ {
+ uintnat pc = caml_last_return_address;
+ /* note that [caml_bottom_of_stack] always points to the most recent
+ * frame, independently of the [Stack_grows_upwards] setting */
+ char * sp = caml_bottom_of_stack;
+ char * limitsp = caml_top_of_stack;
+
+ trace_size = 0;
+ while (1) {
+ frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+ if (descr == NULL) break;
+ if (trace_size >= max_frames) break;
+ ++trace_size;
+
+#ifndef Stack_grows_upwards
+ if (sp > limitsp) break;
+#else
+ if (sp < limitsp) break;
+#endif
+ }
+ }
+
+ trace = caml_alloc((mlsize_t) trace_size, Abstract_tag);
+
+ /* then collect the trace */
+ {
+ uintnat pc = caml_last_return_address;
+ char * sp = caml_bottom_of_stack;
+ intnat trace_pos;
+
+ for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
+ frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+ Assert(descr != NULL);
+ /* The assignment below is safe without [caml_initialize], even
+ if the trace is large and allocated on the old heap, because
+ we assign values that are outside the OCaml heap. */
+ Assert(!(Is_block((value) descr) && Is_in_heap((value) descr)));
+ Field(trace, trace_pos) = (value) descr;
+ }
+ }
+
+ CAMLreturn(trace);
+}
+
/* Extract location information for the given frame descriptor */
struct loc_info {
li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26);
}
+/* Print location information -- same behavior as in Printexc
+
+ note that the test for compiler-inserted raises is slightly redundant:
+ (!li->loc_valid && li->loc_is_raise)
+ extract_location_info above guarantees that when li->loc_valid is
+ 0, then li->loc_is_raise is always 1, so the latter test is
+ useless. We kept it to keep code identical to the byterun/
+ implementation. */
+
static void print_location(struct loc_info * li, int index)
{
char * info;
/* Ignore compiler-inserted raise */
- if (!li->loc_valid) return;
-
- if (index == 0)
- info = "Raised at";
- else if (li->loc_is_raise)
- info = "Re-raised at";
- else
- info = "Called from";
- fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n",
- info, li->loc_filename, li->loc_lnum,
- li->loc_startchr, li->loc_endchr);
+ if (!li->loc_valid && li->loc_is_raise) return;
+
+ if (li->loc_is_raise) {
+ /* Initial raise if index == 0, re-raise otherwise */
+ if (index == 0)
+ info = "Raised at";
+ else
+ info = "Re-raised at";
+ } else {
+ if (index == 0)
+ info = "Raised by primitive operation at";
+ else
+ info = "Called from";
+ }
+ if (! li->loc_valid) {
+ fprintf(stderr, "%s unknown location\n", info);
+ } else {
+ fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n",
+ info, li->loc_filename, li->loc_lnum,
+ li->loc_startchr, li->loc_endchr);
+ }
}
/* Print a backtrace */
}
}
-/* Convert the backtrace to a data structure usable from OCaml */
+/* Convert the raw backtrace to a data structure usable from OCaml */
-CAMLprim value caml_get_exception_backtrace(value unit)
-{
- CAMLparam0();
+CAMLprim value caml_convert_raw_backtrace(value backtrace) {
+ CAMLparam1(backtrace);
CAMLlocal4(res, arr, p, fname);
int i;
struct loc_info li;
- arr = caml_alloc(caml_backtrace_pos, 0);
- for (i = 0; i < caml_backtrace_pos; i++) {
- extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li);
+ arr = caml_alloc(Wosize_val(backtrace), 0);
+ for (i = 0; i < Wosize_val(backtrace); i++) {
+ extract_location_info((frame_descr *) Field(backtrace, i), &li);
if (li.loc_valid) {
fname = caml_copy_string(li.loc_filename);
p = caml_alloc_small(5, 0);
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
CAMLreturn(res);
}
+
+/* Get a copy of the latest backtrace */
+
+CAMLprim value caml_get_exception_raw_backtrace(value unit)
+{
+ CAMLparam0();
+ CAMLlocal1(res);
+ res = caml_alloc(caml_backtrace_pos, Abstract_tag);
+ if(caml_backtrace_buffer != NULL)
+ memcpy(&Field(res, 0), caml_backtrace_buffer,
+ caml_backtrace_pos * sizeof(code_t));
+ CAMLreturn(res);
+}
+
+/* the function below is deprecated: we previously returned directly
+ the OCaml-usable representation, instead of the raw backtrace as an
+ abstract type, but this has a large performance overhead if you
+ store a lot of backtraces and print only some of them.
+
+ It is not used by the Printexc library anymore, or anywhere else in
+ the compiler, but we have kept it in case some user still depends
+ on it as an external.
+*/
+
+CAMLprim value caml_get_exception_backtrace(value unit)
+{
+ CAMLparam0();
+ CAMLlocal2(raw,res);
+ raw = caml_get_exception_raw_backtrace(unit);
+ res = caml_convert_raw_backtrace(raw);
+ CAMLreturn(res);
+}
/* */
/***********************************************************************/
-/* $Id: fail.c 12128 2012-02-05 09:56:23Z bmeurer $ */
-
/* Raising exceptions from C. */
#include <signal.h>
/* */
/***********************************************************************/
-/* $Id: i386.S 12800 2012-07-30 18:59:07Z doligez $ */
-
/* Asm part of the runtime system, Intel 386 processor */
/* Must be preprocessed by cpp */
#define FUNCTION_ALIGN 2
#endif
+#define FUNCTION(name) \
+ .globl G(name); \
+ .align FUNCTION_ALIGN; \
+ G(name):
+
#ifdef ASM_CFI_SUPPORTED
#define CFI_STARTPROC .cfi_startproc
#define CFI_ENDPROC .cfi_endproc
#if defined(PROFILING)
#if defined(SYS_linux_elf) || defined(SYS_gnu)
#define PROFILE_CAML \
- pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \
+ pushl %ebp; CFI_ADJUST(4); \
+ movl %esp, %ebp; \
+ pushl %eax; CFI_ADJUST(4); \
+ pushl %ecx; CFI_ADJUST(4); \
+ pushl %edx; CFI_ADJUST(4); \
call mcount; \
- popl %edx; popl %ecx; popl %eax; popl %ebp
+ popl %edx; CFI_ADJUST(-4); \
+ popl %ecx; CFI_ADJUST(-4); \
+ popl %eax; CFI_ADJUST(-4); \
+ popl %ebp; CFI_ADJUST(-4)
#define PROFILE_C \
- pushl %ebp; movl %esp, %ebp; call mcount; popl %ebp
+ pushl %ebp; CFI_ADJUST(4); \
+ movl %esp, %ebp; \
+ call mcount; \
+ popl %ebp; CFI_ADJUST(-4)
#elif defined(SYS_bsd_elf)
#define PROFILE_CAML \
- pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \
+ pushl %ebp; CFI_ADJUST(4); \
+ movl %esp, %ebp; \
+ pushl %eax; CFI_ADJUST(4); \
+ pushl %ecx; CFI_ADJUST(4); \
+ pushl %edx; CFI_ADJUST(4); \
call .mcount; \
- popl %edx; popl %ecx; popl %eax; popl %ebp
+ popl %edx; CFI_ADJUST(-4); \
+ popl %ecx; CFI_ADJUST(-4); \
+ popl %eax; CFI_ADJUST(-4); \
+ popl %ebp; CFI_ADJUST(-4)
#define PROFILE_C \
- pushl %ebp; movl %esp, %ebp; call .mcount; popl %ebp
+ pushl %ebp; CFI_ADJUST(4); \
+ movl %esp, %ebp; \
+ call .mcount; \
+ popl %ebp; CFI_ADJUST(-4)
#elif defined(SYS_macosx)
#define PROFILE_CAML \
- pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \
+ pushl %ebp; CFI_ADJUST(4); \
+ movl %esp, %ebp; \
+ pushl %eax; CFI_ADJUST(4); \
+ pushl %ecx; CFI_ADJUST(4); \
+ pushl %edx; CFI_ADJUST(4); \
call Lmcount$stub; \
- popl %edx; popl %ecx; popl %eax; popl %ebp
+ popl %edx; CFI_ADJUST(-4); \
+ popl %ecx; CFI_ADJUST(-4); \
+ popl %eax; CFI_ADJUST(-4); \
+ popl %ebp; CFI_ADJUST(-4)
#define PROFILE_C \
- pushl %ebp; movl %esp, %ebp; call Lmcount$stub; popl %ebp
+ pushl %ebp; CFI_ADJUST(4); \
+ movl %esp, %ebp; \
+ call Lmcount$stub; \
+ popl %ebp; CFI_ADJUST(-4)
#endif
#else
#define PROFILE_CAML
#endif
#ifdef SYS_macosx
-#define ALIGN_STACK(amount) subl $ amount, %esp
-#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp
+#define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount)
+#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount)
#else
#define ALIGN_STACK(amount)
#define UNDO_ALIGN_STACK(amount)
.globl G(caml_system__code_begin)
G(caml_system__code_begin):
- .globl G(caml_call_gc)
- .globl G(caml_alloc1)
- .globl G(caml_alloc2)
- .globl G(caml_alloc3)
- .globl G(caml_allocN)
-
- .align FUNCTION_ALIGN
-G(caml_call_gc):
+FUNCTION(caml_call_gc)
CFI_STARTPROC
PROFILE_CAML
/* Record lowest stack address and return address */
addl $16384, %esp
#endif
/* Build array of registers, save it into caml_gc_regs */
- pushl %ebp
- pushl %edi
- pushl %esi
- pushl %edx
- pushl %ecx
- pushl %ebx
- pushl %eax
- CFI_ADJUST(28)
+ pushl %ebp; CFI_ADJUST(4)
+ pushl %edi; CFI_ADJUST(4)
+ pushl %esi; CFI_ADJUST(4)
+ pushl %edx; CFI_ADJUST(4)
+ pushl %ecx; CFI_ADJUST(4)
+ pushl %ebx; CFI_ADJUST(4)
+ pushl %eax; CFI_ADJUST(4)
movl %esp, G(caml_gc_regs)
/* MacOSX note: 16-alignment of stack preserved at this point */
/* Call the garbage collector */
call G(caml_garbage_collection)
/* Restore all regs used by the code generator */
- popl %eax
- popl %ebx
- popl %ecx
- popl %edx
- popl %esi
- popl %edi
- popl %ebp
- CFI_ADJUST(-28)
+ popl %eax; CFI_ADJUST(-4)
+ popl %ebx; CFI_ADJUST(-4)
+ popl %ecx; CFI_ADJUST(-4)
+ popl %edx; CFI_ADJUST(-4)
+ popl %esi; CFI_ADJUST(-4)
+ popl %edi; CFI_ADJUST(-4)
+ popl %ebp; CFI_ADJUST(-4)
/* Return to caller */
ret
CFI_ENDPROC
- .align FUNCTION_ALIGN
-G(caml_alloc1):
+FUNCTION(caml_alloc1)
+ CFI_STARTPROC
PROFILE_CAML
movl G(caml_young_ptr), %eax
subl $8, %eax
call LBL(105)
UNDO_ALIGN_STACK(12)
jmp G(caml_alloc1)
+ CFI_ENDPROC
- .align FUNCTION_ALIGN
-G(caml_alloc2):
+FUNCTION(caml_alloc2)
+ CFI_STARTPROC
PROFILE_CAML
movl G(caml_young_ptr), %eax
subl $12, %eax
call LBL(105)
UNDO_ALIGN_STACK(12)
jmp G(caml_alloc2)
+ CFI_ENDPROC
- .align FUNCTION_ALIGN
-G(caml_alloc3):
+FUNCTION(caml_alloc3)
+ CFI_STARTPROC
PROFILE_CAML
movl G(caml_young_ptr), %eax
subl $16, %eax
call LBL(105)
UNDO_ALIGN_STACK(12)
jmp G(caml_alloc3)
+ CFI_ENDPROC
- .align FUNCTION_ALIGN
-G(caml_allocN):
+FUNCTION(caml_allocN)
+ CFI_STARTPROC
PROFILE_CAML
subl G(caml_young_ptr), %eax /* eax = size - caml_young_ptr */
negl %eax /* eax = caml_young_ptr - size */
LBL(103):
subl G(caml_young_ptr), %eax /* eax = - size */
negl %eax /* eax = size */
- pushl %eax /* save desired size */
+ pushl %eax; CFI_ADJUST(4) /* save desired size */
subl %eax, G(caml_young_ptr) /* must update young_ptr */
movl 4(%esp), %eax
movl %eax, G(caml_last_return_address)
ALIGN_STACK(8)
call LBL(105)
UNDO_ALIGN_STACK(8)
- popl %eax /* recover desired size */
+ popl %eax; CFI_ADJUST(-4) /* recover desired size */
jmp G(caml_allocN)
+ CFI_ENDPROC
/* Call a C function from OCaml */
- .globl G(caml_c_call)
- .align FUNCTION_ALIGN
-G(caml_c_call):
+FUNCTION(caml_c_call)
+ CFI_STARTPROC
PROFILE_CAML
/* Record lowest stack address and return address */
movl (%esp), %edx
#endif
/* Call the function (address in %eax) */
jmp *%eax
+ CFI_ENDPROC
/* Start the OCaml program */
- .globl G(caml_start_program)
- .align FUNCTION_ALIGN
-G(caml_start_program):
+FUNCTION(caml_start_program)
CFI_STARTPROC
PROFILE_C
/* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
- CFI_ADJUST(16)
+ pushl %ebx; CFI_ADJUST(4)
+ pushl %esi; CFI_ADJUST(4)
+ pushl %edi; CFI_ADJUST(4)
+ pushl %ebp; CFI_ADJUST(4)
/* Initial entry point is caml_program */
movl $ G(caml_program), %esi
/* Common code for caml_start_program and caml_callback* */
LBL(106):
/* Build a callback link */
- pushl G(caml_gc_regs)
- pushl G(caml_last_return_address)
- pushl G(caml_bottom_of_stack)
+ pushl G(caml_gc_regs); CFI_ADJUST(4)
+ pushl G(caml_last_return_address); CFI_ADJUST(4)
+ pushl G(caml_bottom_of_stack); CFI_ADJUST(4)
/* Note: 16-alignment preserved on MacOSX at this point */
/* Build an exception handler */
- pushl $ LBL(108)
+ pushl $ LBL(108); CFI_ADJUST(4)
ALIGN_STACK(8)
- pushl G(caml_exception_pointer)
- CFI_ADJUST(20)
+ pushl G(caml_exception_pointer); CFI_ADJUST(4)
movl %esp, G(caml_exception_pointer)
/* Call the OCaml code */
call *%esi
LBL(107):
/* Pop the exception handler */
- popl G(caml_exception_pointer)
+ popl G(caml_exception_pointer); CFI_ADJUST(-4)
#ifdef SYS_macosx
- addl $12, %esp
+ addl $12, %esp ; CFI_ADJUST(-12)
#else
- addl $4, %esp
+ addl $4, %esp ; CFI_ADJUST(-4)
#endif
- CFI_ADJUST(-8)
LBL(109):
/* Pop the callback link, restoring the global variables */
- popl G(caml_bottom_of_stack)
- popl G(caml_last_return_address)
- popl G(caml_gc_regs)
+ popl G(caml_bottom_of_stack); CFI_ADJUST(-4)
+ popl G(caml_last_return_address); CFI_ADJUST(-4)
+ popl G(caml_gc_regs); CFI_ADJUST(-4)
/* Restore callee-save registers. */
- popl %ebp
- popl %edi
- popl %esi
- popl %ebx
+ popl %ebp; CFI_ADJUST(-4)
+ popl %edi; CFI_ADJUST(-4)
+ popl %esi; CFI_ADJUST(-4)
+ popl %ebx; CFI_ADJUST(-4)
/* Return to caller. */
ret
LBL(108):
/* Raise an exception from OCaml */
- .globl G(caml_raise_exn)
- .align FUNCTION_ALIGN
-G(caml_raise_exn):
+FUNCTION(caml_raise_exn)
+ CFI_STARTPROC
testl $1, G(caml_backtrace_active)
jne LBL(110)
movl G(caml_exception_pointer), %esp
- popl G(caml_exception_pointer)
+ popl G(caml_exception_pointer); CFI_ADJUST(-4)
UNDO_ALIGN_STACK(8)
ret
LBL(110):
movl 0(%esp), %eax /* PC of raise */
leal 4(%esp), %edx /* SP of raise */
ALIGN_STACK(12)
- pushl %edi /* arg 4: sp of handler */
- pushl %edx /* arg 3: sp of raise */
- pushl %eax /* arg 2: pc of raise */
- pushl %esi /* arg 1: exception bucket */
+ pushl %edi; CFI_ADJUST(4) /* arg 4: sp of handler */
+ pushl %edx; CFI_ADJUST(4) /* arg 3: sp of raise */
+ pushl %eax; CFI_ADJUST(4) /* arg 2: pc of raise */
+ pushl %esi; CFI_ADJUST(4) /* arg 1: exception bucket */
call G(caml_stash_backtrace)
movl %esi, %eax /* Recover exception bucket */
movl %edi, %esp
- popl G(caml_exception_pointer)
+ popl G(caml_exception_pointer); CFI_ADJUST(-4)
UNDO_ALIGN_STACK(8)
ret
+ CFI_ENDPROC
/* Raise an exception from C */
- .globl G(caml_raise_exception)
- .align FUNCTION_ALIGN
-G(caml_raise_exception):
+FUNCTION(caml_raise_exception)
+ CFI_STARTPROC
PROFILE_C
testl $1, G(caml_backtrace_active)
jne LBL(111)
movl 4(%esp), %eax
movl G(caml_exception_pointer), %esp
- popl G(caml_exception_pointer)
+ popl G(caml_exception_pointer); CFI_ADJUST(-4)
UNDO_ALIGN_STACK(8)
ret
LBL(111):
movl 4(%esp), %esi /* Save exception bucket in esi */
ALIGN_STACK(12)
- pushl G(caml_exception_pointer) /* arg 4: sp of handler */
- pushl G(caml_bottom_of_stack) /* arg 3: sp of raise */
- pushl G(caml_last_return_address) /* arg 2: pc of raise */
- pushl %esi /* arg 1: exception bucket */
+ pushl G(caml_exception_pointer); CFI_ADJUST(4) /* 4: sp of handler */
+ pushl G(caml_bottom_of_stack); CFI_ADJUST(4) /* 3: sp of raise */
+ pushl G(caml_last_return_address); CFI_ADJUST(4)/* 2: pc of raise */
+ pushl %esi; CFI_ADJUST(4) /* 1: exception bucket */
call G(caml_stash_backtrace)
movl %esi, %eax /* Recover exception bucket */
movl G(caml_exception_pointer), %esp
- popl G(caml_exception_pointer)
+ popl G(caml_exception_pointer); CFI_ADJUST(-4)
UNDO_ALIGN_STACK(8)
ret
+ CFI_ENDPROC
/* Callback from C to OCaml */
- .globl G(caml_callback_exn)
- .align FUNCTION_ALIGN
-G(caml_callback_exn):
+FUNCTION(caml_callback_exn)
+ CFI_STARTPROC
PROFILE_C
/* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
+ pushl %ebx; CFI_ADJUST(4)
+ pushl %esi; CFI_ADJUST(4)
+ pushl %edi; CFI_ADJUST(4)
+ pushl %ebp; CFI_ADJUST(4)
/* Initial loading of arguments */
movl 20(%esp), %ebx /* closure */
movl 24(%esp), %eax /* argument */
movl 0(%ebx), %esi /* code pointer */
jmp LBL(106)
+ CFI_ENDPROC
- .globl G(caml_callback2_exn)
- .align FUNCTION_ALIGN
-G(caml_callback2_exn):
+FUNCTION(caml_callback2_exn)
+ CFI_STARTPROC
PROFILE_C
/* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
+ pushl %ebx; CFI_ADJUST(4)
+ pushl %esi; CFI_ADJUST(4)
+ pushl %edi; CFI_ADJUST(4)
+ pushl %ebp; CFI_ADJUST(4)
/* Initial loading of arguments */
movl 20(%esp), %ecx /* closure */
movl 24(%esp), %eax /* first argument */
movl 28(%esp), %ebx /* second argument */
movl $ G(caml_apply2), %esi /* code pointer */
jmp LBL(106)
+ CFI_ENDPROC
- .globl G(caml_callback3_exn)
- .align FUNCTION_ALIGN
-G(caml_callback3_exn):
+FUNCTION(caml_callback3_exn)
+ CFI_STARTPROC
PROFILE_C
/* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
+ pushl %ebx; CFI_ADJUST(4)
+ pushl %esi; CFI_ADJUST(4)
+ pushl %edi; CFI_ADJUST(4)
+ pushl %ebp; CFI_ADJUST(4)
/* Initial loading of arguments */
movl 20(%esp), %edx /* closure */
movl 24(%esp), %eax /* first argument */
movl 32(%esp), %ecx /* third argument */
movl $ G(caml_apply3), %esi /* code pointer */
jmp LBL(106)
+ CFI_ENDPROC
- .globl G(caml_ml_array_bound_error)
- .align FUNCTION_ALIGN
-G(caml_ml_array_bound_error):
+FUNCTION(caml_ml_array_bound_error)
+ CFI_STARTPROC
/* Empty the floating-point stack */
ffree %st(0)
ffree %st(1)
#endif
/* Branch to [caml_array_bound_error] (never returns) */
call G(caml_array_bound_error)
+ CFI_ENDPROC
.globl G(caml_system__code_end)
G(caml_system__code_end):
;* *
;***********************************************************************
-; $Id: i386nt.asm 12800 2012-07-30 18:59:07Z doligez $
-
; Asm part of the runtime system, Intel 386 processor, Intel syntax
.386
#include "callback.h"
#include "alloc.h"
#include "intext.h"
-#include "natdynlink.h"
#include "osdeps.h"
#include "fail.h"
/* */
/***********************************************************************/
-/* $Id: power-elf.S 12800 2012-07-30 18:59:07Z doligez $ */
-
#define Addrglobal(reg,glob) \
addis reg, 0, glob@ha; \
addi reg, reg, glob@l
/* */
/***********************************************************************/
-/* $Id: power-rhapsody.S 12800 2012-07-30 18:59:07Z doligez $ */
-
#ifdef __ppc64__
#define X(a,b) b
#else
/* */
/***********************************************************************/
-/* $Id: roots.c 12800 2012-07-30 18:59:07Z doligez $ */
-
/* To walk the memory roots for garbage collection */
#include "finalise.h"
/* */
/***********************************************************************/
-/* $Id: signals_asm.c 12159 2012-02-17 10:12:09Z xleroy $ */
-
/* Signal handling, code specific to the native-code compiler */
#if defined(TARGET_amd64) && defined (SYS_linux)
#define _GNU_SOURCE
#endif
#include <signal.h>
+#include <errno.h>
#include <stdio.h>
#include "fail.h"
#include "memory.h"
DECLARE_SIGNAL_HANDLER(handle_signal)
{
+ int saved_errno;
+ /* Save the value of errno (PR#5982). */
+ saved_errno = errno;
#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
signal(sig, handle_signal);
#endif
CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit;
#endif
}
+ errno = saved_errno;
}
int caml_set_signal_action(int signo, int action)
#define EXTRA_STACK 0x2000
#endif
+#ifdef RETURN_AFTER_STACK_OVERFLOW
+extern void caml_stack_overflow(void);
+#endif
+
DECLARE_SIGNAL_HANDLER(segv_handler)
{
struct rlimit limit;
&& Is_in_code_area(CONTEXT_PC)
#endif
) {
- /* Turn this into a Stack_overflow exception */
+#ifdef RETURN_AFTER_STACK_OVERFLOW
+ /* Tweak the PC part of the context so that on return from this
+ handler, we jump to the asm function [caml_stack_overflow]
+ (from $ARCH.S). */
+#ifdef CONTEXT_PC
+ CONTEXT_PC = (context_reg) &caml_stack_overflow;
+#else
+#error "CONTEXT_PC must be defined if RETURN_AFTER_STACK_OVERFLOW is"
+#endif
+#else
+ /* Raise a Stack_overflow exception straight from this signal handler */
#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER)
caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
caml_young_ptr = (char *) CONTEXT_YOUNG_PTR;
#endif
caml_raise_stack_overflow();
+#endif
+ } else {
+ /* Otherwise, deactivate our exception handler and return,
+ causing fatal signal to be generated at point of error. */
+ act.sa_handler = SIG_DFL;
+ act.sa_flags = 0;
+ sigemptyset(&act.sa_mask);
+ sigaction(SIGSEGV, &act, NULL);
}
- /* Otherwise, deactivate our exception handler and return,
- causing fatal signal to be generated at point of error. */
- act.sa_handler = SIG_DFL;
- act.sa_flags = 0;
- sigemptyset(&act.sa_mask);
- sigaction(SIGSEGV, &act, NULL);
}
#endif
/* */
/***********************************************************************/
-/* $Id: signals_osdep.h 12124 2012-02-04 10:15:24Z bmeurer $ */
-
/* Processor- and OS-dependent signal interface */
/****************** AMD64, Linux */
#define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
- #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.gregs[REG_CR2])
+ #define CONTEXT_FAULTING_ADDRESS ((char *)context->uc_mcontext.gregs[REG_CR2])
/****************** AMD64, MacOSX */
#include <sys/ucontext.h>
#include <AvailabilityMacros.h>
-#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
+ #if !defined(MAC_OS_X_VERSION_10_5) \
+ || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
#define CONTEXT_REG(r) r
#else
#define CONTEXT_REG(r) __##r
#endif
+ typedef unsigned long long context_reg;
#define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss))
#define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(rip))
#define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r14))
#define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp))
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
-/****************** ARM, Linux */
+ #define RETURN_AFTER_STACK_OVERFLOW
-#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) || defined(SYS_linux_eabihf))
+/****************** ARM, Linux */
- #include <sys/ucontext.h>
+#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) \
+ || defined(SYS_linux_eabihf))
+
+ #if defined(__ANDROID__)
+ // The Android NDK does not have sys/ucontext.h yet.
+ typedef struct ucontext {
+ uint32_t uc_flags;
+ struct ucontext *uc_link;
+ stack_t uc_stack;
+ struct sigcontext uc_mcontext;
+ // Other fields omitted...
+ } ucontext_t;
+ #else
+ #include <sys/ucontext.h>
+ #endif
#define DECLARE_SIGNAL_HANDLER(name) \
static void name(int sig, siginfo_t * info, ucontext_t * context)
#include <sys/ucontext.h>
#include <AvailabilityMacros.h>
-#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
+ #if !defined(MAC_OS_X_VERSION_10_5) \
+ || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
#define CONTEXT_REG(r) r
#else
#define CONTEXT_REG(r) __##r
#define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext)
#endif
-#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
+ #if !defined(MAC_OS_X_VERSION_10_5) \
+ || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
#define CONTEXT_REG(r) r
#else
#define CONTEXT_REG(r) __##r
/****************** PowerPC, BSD */
-#elif defined(TARGET_power) && defined(SYS_bsd)
+#elif defined(TARGET_power) && (defined(SYS_bsd) || defined(SYS_bsd_elf))
#define DECLARE_SIGNAL_HANDLER(name) \
static void name(int sig, int code, struct sigcontext * context)
/* */
/***********************************************************************/
-/* $Id: sparc.S 12800 2012-07-30 18:59:07Z doligez $ */
-
/* Asm part of the runtime system for the Sparc processor. */
/* Must be preprocessed by cpp */
/* */
/***********************************************************************/
-/* $Id: stack.h 12159 2012-02-17 10:12:09Z xleroy $ */
-
/* Machine-dependent interface with the asm code */
#ifndef CAML_STACK_H
#ifdef TARGET_power
#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR))
#define Already_scanned(sp, retaddr) ((retaddr) & 1)
-#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1)
+#define Mark_scanned(sp, retaddr) \
+ (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1)
#define Mask_already_scanned(retaddr) ((retaddr) & ~1)
#ifdef SYS_aix
#define Trap_frame_size 32
/* */
/***********************************************************************/
-/* $Id: startup.c 12227 2012-03-13 14:44:48Z xleroy $ */
-
/* Start-up code */
#include <stdio.h>
#include "printexc.h"
#include "stack.h"
#include "sys.h"
-#include "natdynlink.h"
#ifdef HAS_UI
#include "ui.h"
#endif
}
if (caml_page_table_add(In_static_data,
caml_atom_table, caml_atom_table + 256) != 0)
- caml_fatal_error("Fatal error: not enough memory for the initial page table");
+ caml_fatal_error("Fatal error: not enough memory for initial page table");
for (i = 0; caml_data_segments[i].begin != 0; i++) {
/* PR#5509: we must include the zero word at end of data segment,
if (caml_page_table_add(In_static_data,
caml_data_segments[i].begin,
caml_data_segments[i].end + sizeof(value)) != 0)
- caml_fatal_error("Fatal error: not enough memory for the initial page table");
+ caml_fatal_error("Fatal error: not enough memory for initial page table");
}
caml_code_area_start = caml_code_segments[0].begin;
extern void caml_init_ieee_floats (void);
extern void caml_init_signals (void);
+#ifdef _MSC_VER
+
+/* PR 4887: avoid crash box of windows runtime on some system calls */
+extern void caml_install_invalid_parameter_handler();
+
+#endif
+
+
void caml_main(char **argv)
{
char * exe_name;
char tos;
caml_init_ieee_floats();
+#ifdef _MSC_VER
+ caml_install_invalid_parameter_handler();
+#endif
caml_init_custom_operations();
#ifdef DEBUG
caml_verb_gc = 63;
# #
#########################################################################
-# $Id: boot.sh 11156 2011-07-27 14:17:02Z doligez $
cd `dirname $0`/..
set -ex
TAG_LINE='true: -use_stdlib'
-./boot/ocamlrun boot/myocamlbuild.boot \
+
+# If you modify this list, modify it also in camlp4-native-only.sh
+STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack'
+
+./boot/ocamlrun boot/myocamlbuild.boot -ignore "$STDLIB_MODULES" \
-tag-line "$TAG_LINE" \
boot/stdlib.cma boot/std_exit.cmo
+#########################################################################
+# #
+# OCaml #
+# #
+# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
=== Initial setup ===
make clean
./build/distclean.sh
# #
#########################################################################
-# $Id: camlp4-byte-only.sh 11156 2011-07-27 14:17:02Z doligez $
-
set -e
cd `dirname $0`/..
. build/targets.sh
# #
#########################################################################
-# $Id: camlp4-mkCamlp4Ast.sh 11156 2011-07-27 14:17:02Z doligez $
set -e
cd `dirname $0`/..
# #
#########################################################################
-# $Id: camlp4-native-only.sh 11156 2011-07-27 14:17:02Z doligez $
-
set -e
cd `dirname $0`/..
. build/targets.sh
set -x
-$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE
+
+# If you modify this list, modify it also in boot.sh
+STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack'
+
+$OCAMLBUILD -ignore "$STDLIB_MODULES" $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE
# #
#########################################################################
-# $Id: camlp4-targets.sh 11156 2011-07-27 14:17:02Z doligez $
CAMLP4_COMMON="\
camlp4/Camlp4/Camlp4Ast.partial.ml \
camlp4/boot/camlp4boot.byte"
# #
#########################################################################
-# $Id: distclean.sh 11156 2011-07-27 14:17:02Z doligez $
-
cd `dirname $0`/..
set -ex
(cd byterun && make clean) || :
# #
#########################################################################
-# $Id: fastworld.sh 11156 2011-07-27 14:17:02Z doligez $
-
cd `dirname $0`
set -e
if [ -e ocamlbuild_mixed_mode ]; then
# #
#########################################################################
-# $Id: install.sh 11156 2011-07-27 14:17:02Z doligez $
-
set -e
cd `dirname $0`/..
ocamlbuildlib.cmxa \
ocamlbuildlib.cma \
ocamlbuild_plugin.cmi \
+ ocamlbuild_plugin.cmo \
+ ocamlbuild_plugin.cmx \
ocamlbuild_pack.cmi \
ocamlbuild_unix_plugin.cmi \
ocamlbuild_unix_plugin.cmo \
# #
#########################################################################
-# $Id: mkmyocamlbuild_config.sh 11156 2011-07-27 14:17:02Z doligez $
-
cd `dirname $0`/..
sed \
-e 's/^.*FLEXDIR.*$//g' \
+ -e '/^SET_LD_PATH/d' \
-e 's/^#ml \(.*\)/\1/' \
-e 's/^\([^"][^"]*\("[^"]*"[^"]*\)*\)#.*$/\1/' \
-e 's/^\(#.*\)$/(* \1 *)/' \
# #
#########################################################################
-# $Id: mkruntimedef.sh 11156 2011-07-27 14:17:02Z doligez $
echo 'let builtin_exceptions = [|'; \
sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \
sed -e '$s/;$//'; \
# #
#########################################################################
-# $Id: myocamlbuild.sh 11156 2011-07-27 14:17:02Z doligez $
-
cd `dirname $0`/..
set -xe
if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then
+#########################################################################
+# #
+# OCaml #
+# #
+# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2007 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
_tags # Defines tags to setup exceptions
myocamlbuild.ml # Contains all needed rules that are differents
boot/ocamldep
# #
#########################################################################
-# $Id: ocamlbuild-byte-only.sh 11156 2011-07-27 14:17:02Z doligez $
-
set -e
cd `dirname $0`/..
. build/targets.sh
# #
#########################################################################
-# $Id: ocamlbuild-native-only.sh 11156 2011-07-27 14:17:02Z doligez $
-
set -e
cd `dirname $0`/..
. build/targets.sh
# #
#########################################################################
-# $Id: ocamlbuildlib-native-only.sh 11156 2011-07-27 14:17:02Z doligez $
-
set -e
cd `dirname $0`/..
. build/targets.sh
# #
#########################################################################
-# $Id: otherlibs-targets.sh 11156 2011-07-27 14:17:02Z doligez $
-
OTHERLIBS_BYTE=""
OTHERLIBS_NATIVE=""
OTHERLIBS_UNIX_NATIVE=""
# #
#########################################################################
-# $Id: partial-install.sh 12113 2012-02-03 12:03:04Z bmeurer $
-
######################################
######### Copied from build/install.sh
######################################
ocamlbuildlib.cmxa \
ocamlbuildlib.cma \
ocamlbuild_plugin.cmi \
+ ocamlbuild_plugin.cmo \
+ ocamlbuild_plugin.cmx \
ocamlbuild_pack.cmi \
ocamlbuild_unix_plugin.cmi \
ocamlbuild_unix_plugin.cmo \
# #
#########################################################################
-# $Id: targets.sh 11156 2011-07-27 14:17:02Z doligez $
-
. config/config.sh
. build/otherlibs-targets.sh
. build/camlp4-targets.sh
# #
#########################################################################
-# $Id: world.all.sh 11156 2011-07-27 14:17:02Z doligez $
set -e
cd `dirname $0`/..
. build/targets.sh
# #
#########################################################################
-# $Id: world.byte.sh 11156 2011-07-27 14:17:02Z doligez $
set -e
cd `dirname $0`/..
. build/targets.sh
# #
#########################################################################
-# $Id: world.native.sh 11156 2011-07-27 14:17:02Z doligez $
set -e
cd `dirname $0`/..
. build/targets.sh
(* *)
(***********************************************************************)
-(* $Id: bytegen.ml 12167 2012-02-18 17:21:42Z xleroy $ *)
-
(* bytegen.ml : translation of lambda terms to lists of instructions. *)
open Misc
| Pstringsets -> Kccall("caml_string_set", 3)
| Pstringrefu -> Kgetstringchar
| Pstringsetu -> Ksetstringchar
+ | Pstring_load_16(_) -> Kccall("caml_string_get16", 2)
+ | Pstring_load_32(_) -> Kccall("caml_string_get32", 2)
+ | Pstring_load_64(_) -> Kccall("caml_string_get64", 2)
+ | Pstring_set_16(_) -> Kccall("caml_string_set16", 3)
+ | Pstring_set_32(_) -> Kccall("caml_string_set32", 3)
+ | Pstring_set_64(_) -> Kccall("caml_string_set64", 3)
| Parraylength kind -> Kvectlength
| Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
| Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2)
| Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3)
| Parraysetu Pfloatarray -> Kccall("caml_array_unsafe_set_float", 3)
| Parraysetu _ -> Ksetvectitem
+ | Pctconst c ->
+ let const_name = match c with
+ | Big_endian -> "big_endian"
+ | Word_size -> "word_size"
+ | Ostype_unix -> "ostype_unix"
+ | Ostype_win32 -> "ostype_win32"
+ | Ostype_cygwin -> "ostype_cygwin" in
+ Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
| Pisint -> Kisint
| Pisout -> Kisout
| Pbittest -> Kccall("caml_bitvect_test", 2)
| Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2)
| Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1)
| Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2)
+ | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1)
+ | Pbigstring_load_16(_) -> Kccall("caml_ba_uint8_get16", 2)
+ | Pbigstring_load_32(_) -> Kccall("caml_ba_uint8_get32", 2)
+ | Pbigstring_load_64(_) -> Kccall("caml_ba_uint8_get64", 2)
+ | Pbigstring_set_16(_) -> Kccall("caml_ba_uint8_set16", 3)
+ | Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3)
+ | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3)
+ | Pbswap16 -> Kccall("caml_bswap16", 1)
+ | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args
| _ -> fatal_error "Bytegen.comp_primitive"
let is_immed n = immed_min <= n && n <= immed_max
(* *)
(***********************************************************************)
-(* $Id: bytegen.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Generation of bytecode from lambda terms *)
open Lambda
(* *)
(***********************************************************************)
-(* $Id: bytelibrarian.ml 12202 2012-03-07 17:50:17Z frisch $ *)
-
(* Build libraries of .cmo files *)
open Misc
(* Add C objects and options and "custom" info from a library descriptor *)
-let lib_sharedobjs = ref []
let lib_ccobjs = ref []
let lib_ccopts = ref []
let lib_dllibs = ref []
output_string outchan cma_magic_number;
let ofs_pos_toc = pos_out outchan in
output_binary_int outchan 0;
- let units = List.flatten(List.map (copy_object_file ppf outchan) file_list) in
+ let units =
+ List.flatten(List.map (copy_object_file ppf outchan) file_list) in
let toc =
{ lib_units = units;
lib_custom = !Clflags.custom_runtime;
lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs;
- lib_ccopts = !Clflags.ccopts @ !lib_ccopts;
+ lib_ccopts = !Clflags.all_ccopts @ !lib_ccopts;
lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in
let pos_toc = pos_out outchan in
output_value outchan toc;
(* *)
(***********************************************************************)
-(* $Id: bytelibrarian.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Build libraries of .cmo files *)
(* Format of a library file:
(* *)
(***********************************************************************)
-(* $Id: bytelink.ml 12357 2012-04-16 15:27:42Z frisch $ *)
-
(* Link a set of .cmo files and produce a bytecode executable. *)
-open Sys
open Misc
open Config
-open Instruct
open Cmo_format
type error =
File_not_found of string
| Not_an_object_file of string
+ | Wrong_object_name of string
| Symbol_error of string * Symtable.error
| Inconsistent_import of string * string * string
| Custom_runtime
| File_exists of string
| Cannot_open_dll of string
-
+ | Not_compatible_32
exception Error of error
begin try
let source = List.assoc cu.cu_name !implementations_defined in
Location.print_warning (Location.in_file file_name) ppf
- (Warnings.Multiple_definition(cu.cu_name, Location.show_filename file_name, Location.show_filename source))
+ (Warnings.Multiple_definition(cu.cu_name,
+ Location.show_filename file_name,
+ Location.show_filename source))
with Not_found -> ()
end;
implementations_defined :=
(* Record compilation events *)
-let debug_info = ref ([] : (int * string) list)
+let debug_info = ref ([] : (int * LongString.t) list)
(* Link in a compilation unit *)
let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
check_consistency ppf file_name compunit;
seek_in inchan compunit.cu_pos;
- let code_block = input_bytes inchan compunit.cu_codesize in
- Symtable.patch_object code_block compunit.cu_reloc;
+ let code_block = LongString.input_bytes inchan compunit.cu_codesize in
+ Symtable.ls_patch_object code_block compunit.cu_reloc;
if !Clflags.debug && compunit.cu_debug > 0 then begin
seek_in inchan compunit.cu_debug;
- let buffer = input_bytes inchan compunit.cu_debugsize in
+ let buffer = LongString.input_bytes inchan compunit.cu_debugsize in
debug_info := (currpos_fun(), buffer) :: !debug_info
end;
- output_fun code_block;
+ Array.iter output_fun code_block;
if !Clflags.link_everything then
List.iter Symtable.require_primitive compunit.cu_primitives
let output_debug_info oc =
output_binary_int oc (List.length !debug_info);
List.iter
- (fun (ofs, evl) -> output_binary_int oc ofs; output_string oc evl)
+ (fun (ofs, evl) ->
+ output_binary_int oc ofs;
+ Array.iter (output_string oc) evl)
!debug_info;
debug_info := []
(* Create a bytecode executable file *)
let link_bytecode ppf tolink exec_name standalone =
+ (* Avoid the case where the specified exec output file is the same as
+ one of the objects to be linked *)
+ List.iter (function
+ | Link_object(file_name, _) when file_name = exec_name ->
+ raise (Error (Wrong_object_name exec_name));
+ | _ -> ()) tolink;
Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *)
let outchan =
open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
Symtable.output_primitive_names outchan;
Bytesections.record outchan "PRIM";
(* The table of global data *)
- output_value outchan (Symtable.initial_global_table());
+ begin try
+ Marshal.to_channel outchan (Symtable.initial_global_table())
+ (if !Clflags.bytecode_compatible_32
+ then [Marshal.Compat_32] else [])
+ with Failure _ ->
+ raise (Error Not_compatible_32)
+ end;
Bytesections.record outchan "DATA";
(* The map of global identifiers *)
Symtable.output_global_map outchan;
else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in
let tolink = List.fold_right scan_file objfiles [] in
Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *)
- Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *)
+ Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
+ (* put user's opts first *)
Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *)
if not !Clflags.custom_runtime then
link_bytecode ppf tolink output_name true
| Not_an_object_file name ->
fprintf ppf "The file %a is not a bytecode object file"
Location.print_filename name
+ | Wrong_object_name name ->
+ fprintf ppf "The output file %s has the wrong name. The extension implies\
+ \ an object file but the link step was requested" name
| Symbol_error(name, err) ->
fprintf ppf "Error while linking %a:@ %a" Location.print_filename name
Symtable.report_error err
| Cannot_open_dll file ->
fprintf ppf "Error on dynamically loaded library: %a"
Location.print_filename file
+ | Not_compatible_32 ->
+ fprintf ppf "Generated bytecode executable cannot be run\
+ \ on a 32-bit platform"
(* *)
(***********************************************************************)
-(* $Id: bytelink.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Link .cmo files and produce a bytecode executable. *)
val link : Format.formatter -> string list -> string -> unit
-val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit
+val check_consistency:
+ Format.formatter -> string -> Cmo_format.compilation_unit -> unit
val extract_crc_interfaces: unit -> (string * Digest.t) list
type error =
File_not_found of string
| Not_an_object_file of string
+ | Wrong_object_name of string
| Symbol_error of string * Symtable.error
| Inconsistent_import of string * string * string
| Custom_runtime
| File_exists of string
| Cannot_open_dll of string
+ | Not_compatible_32
exception Error of error
(* *)
(***********************************************************************)
-(* $Id: bytepackager.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* "Package" a set of .cmo files into one .cmo file having the
original compilation units as sub-modules. *)
Forward_reference of string * Ident.t
| Multiple_definition of string * Ident.t
| Not_an_object_file of string
- | Illegal_renaming of string * string
+ | Illegal_renaming of string * string * string
| File_not_found of string
exception Error of error
pm_name: string;
pm_kind: pack_member_kind }
-let read_member_info file =
+let read_member_info file = (
let name =
String.capitalize(Filename.basename(chop_extensions file)) in
let kind =
seek_in ic compunit_pos;
let compunit = (input_value ic : compilation_unit) in
if compunit.cu_name <> name
- then raise(Error(Illegal_renaming(file, compunit.cu_name)));
+ then raise(Error(Illegal_renaming(name, file, compunit.cu_name)));
close_in ic;
PM_impl compunit
with x ->
end else
PM_intf in
{ pm_file = file; pm_name = name; pm_kind = kind }
+)
(* Read the bytecode from a .cmo file.
Write bytecode to channel [oc].
Accumulate relocs, debug info, etc.
Return size of bytecode. *)
-let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst objfile compunit =
+let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst
+ objfile compunit =
let ic = open_in_bin objfile in
try
Bytelink.check_consistency ppf objfile compunit;
(* Same, for a list of .cmo and .cmi files.
Return total size of bytecode. *)
-let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs prefix subst = function
+let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs
+ prefix subst =
+ function
[] ->
ofs
| m :: rem ->
match m.pm_kind with
| PM_intf ->
- rename_append_bytecode_list ppf packagename oc mapping defined ofs prefix subst rem
+ rename_append_bytecode_list ppf packagename oc mapping defined ofs
+ prefix subst rem
| PM_impl compunit ->
let size =
- rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst
- m.pm_file compunit in
+ rename_append_bytecode ppf packagename oc mapping defined ofs
+ prefix subst m.pm_file compunit in
let id = Ident.create_persistent m.pm_name in
let root = Path.Pident (Ident.create_persistent prefix) in
- rename_append_bytecode_list ppf packagename
- oc mapping (id :: defined)
- (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem
+ rename_append_bytecode_list ppf packagename oc mapping (id :: defined)
+ (ofs + size) prefix
+ (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos))
+ subst)
+ rem
(* Generate the code that builds the tuple representing the package module *)
let pos_depl = pos_out oc in
output_binary_int oc 0;
let pos_code = pos_out oc in
- let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0 targetname Subst.identity members in
+ let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0
+ targetname Subst.identity members in
build_global_target oc targetname members mapping ofs coercion;
let pos_debug = pos_out oc in
if !Clflags.debug && !events <> [] then
| Not_an_object_file file ->
fprintf ppf "%a is not a bytecode object file"
Location.print_filename file
- | Illegal_renaming(file, id) ->
- fprintf ppf "Wrong file naming: %a@ contains the code for@ %s"
- Location.print_filename file id
+ | Illegal_renaming(name, file, id) ->
+ fprintf ppf "Wrong file naming: %a@ contains the code for\
+ @ %s when %s was expected"
+ Location.print_filename file name id
| File_not_found file ->
fprintf ppf "File %s not found" file
(* *)
(***********************************************************************)
-(* $Id: bytepackager.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* "Package" a set of .cmo files into one .cmo file having the
original compilation units as sub-modules. *)
Forward_reference of string * Ident.t
| Multiple_definition of string * Ident.t
| Not_an_object_file of string
- | Illegal_renaming of string * string
+ | Illegal_renaming of string * string * string
| File_not_found of string
exception Error of error
(* *)
(***********************************************************************)
-(* $Id: bytesections.ml 12184 2012-02-23 19:54:44Z doligez $ *)
-
(* Handling of sections in bytecode executable files *)
(* List of all sections, in reverse order *)
if header <> Config.exec_magic_number then raise Bad_magic_number;
seek_in ic (pos_trailer - 8 * num_sections);
section_table := [];
- for i = 1 to num_sections do
+ for _i = 1 to num_sections do
let name = Misc.input_bytes ic 4 in
let len = input_binary_int ic in
section_table := (name, len) :: !section_table
(* *)
(***********************************************************************)
-(* $Id: bytesections.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Handling of sections in bytecode executable files *)
(** Recording sections written to a bytecode executable file *)
(* *)
(***********************************************************************)
-(* $Id: cmo_format.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Symbol table information for .cmo and .cma files *)
(* Relocation information *)
(* *)
(***********************************************************************)
-(* $Id: dll.ml 12661 2012-07-07 11:41:17Z scherer $ *)
-
(* Handling of dynamically-linked libraries *)
type dll_handle
(* *)
(***********************************************************************)
-(* $Id: dll.mli 12661 2012-07-07 11:41:17Z scherer $ *)
-
(* Handling of dynamically-linked libraries *)
(* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *)
(* *)
(***********************************************************************)
-(* $Id: emitcode.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Generation of bytecode + relocation information *)
open Config
(* Buffering of bytecode *)
-let out_buffer = ref(String.create 1024)
+let out_buffer = ref(LongString.create 1024)
and out_position = ref 0
let out_word b1 b2 b3 b4 =
let p = !out_position in
- if p >= String.length !out_buffer then begin
- let len = String.length !out_buffer in
- let new_buffer = String.create (2 * len) in
- String.blit !out_buffer 0 new_buffer 0 len;
+ if p >= LongString.length !out_buffer then begin
+ let len = LongString.length !out_buffer in
+ let new_buffer = LongString.create (2 * len) in
+ LongString.blit !out_buffer 0 new_buffer 0 len;
out_buffer := new_buffer
end;
- String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
- String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
- String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
- String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
+ LongString.set !out_buffer p (Char.unsafe_chr b1);
+ LongString.set !out_buffer (p+1) (Char.unsafe_chr b2);
+ LongString.set !out_buffer (p+2) (Char.unsafe_chr b3);
+ LongString.set !out_buffer (p+3) (Char.unsafe_chr b4);
out_position := p + 4
let out opcode =
let backpatch (pos, orig) =
let displ = (!out_position - orig) asr 2 in
- !out_buffer.[pos] <- Char.unsafe_chr displ;
- !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
- !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
- !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+ LongString.set !out_buffer pos (Char.unsafe_chr displ);
+ LongString.set !out_buffer (pos+1) (Char.unsafe_chr (displ asr 8));
+ LongString.set !out_buffer (pos+2) (Char.unsafe_chr (displ asr 16));
+ LongString.set !out_buffer (pos+3) (Char.unsafe_chr (displ asr 24))
let define_label lbl =
if lbl >= Array.length !label_table then extend_label_table lbl;
(Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
emit (Kpush :: instr1 :: instr2 :: ev :: c)
| Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
- (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
+ (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr)::
+ c ->
emit (Kpush :: instr :: ev :: c)
| Kgetglobal id :: Kgetfield n :: c ->
out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
output_binary_int outchan 0;
let pos_code = pos_out outchan in
emit code;
- output outchan !out_buffer 0 !out_position;
+ LongString.output outchan !out_buffer 0 !out_position;
let (pos_debug, size_debug) =
if !Clflags.debug then begin
let p = pos_out outchan in
cu_codesize = !out_position;
cu_reloc = List.rev !reloc_info;
cu_imports = Env.imported_units();
- cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations;
+ cu_primitives = List.map Primitive.byte_name
+ !Translmod.primitive_declarations;
cu_force_link = false;
cu_debug = pos_debug;
cu_debugsize = size_debug } in
emit init_code;
emit fun_code;
let code = Meta.static_alloc !out_position in
- String.unsafe_blit !out_buffer 0 code 0 !out_position;
+ LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position;
let reloc = List.rev !reloc_info
and code_size = !out_position in
init();
let to_packed_file outchan code =
init();
emit code;
- output outchan !out_buffer 0 !out_position;
+ LongString.output outchan !out_buffer 0 !out_position;
let reloc = !reloc_info in
init();
reloc
(* *)
(***********************************************************************)
-(* $Id: emitcode.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Generation of bytecode for .cmo files *)
open Cmo_format
(* *)
(***********************************************************************)
-(* $Id: instruct.ml 12149 2012-02-10 16:15:24Z doligez $ *)
-
open Lambda
type compilation_env =
(* *)
(***********************************************************************)
-(* $Id: instruct.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The type of the instructions of the abstract machine *)
open Lambda
(* *)
(***********************************************************************)
-(* $Id: lambda.ml 12070 2012-01-23 14:49:39Z lefessan $ *)
-
open Misc
open Path
open Asttypes
+type compile_time_constant =
+ | Big_endian
+ | Word_size
+ | Ostype_unix
+ | Ostype_win32
+ | Ostype_cygwin
+
type primitive =
Pidentity
| Pignore
(* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
| Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
| Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
+ (* size of the nth dimension of a big array *)
+ | Pbigarraydim of int
+ (* load/set 16,32,64 bits from a string: (unsafe)*)
+ | Pstring_load_16 of bool
+ | Pstring_load_32 of bool
+ | Pstring_load_64 of bool
+ | Pstring_set_16 of bool
+ | Pstring_set_32 of bool
+ | Pstring_set_64 of bool
+ (* load/set 16,32,64 bits from a
+ (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
+ | Pbigstring_load_16 of bool
+ | Pbigstring_load_32 of bool
+ | Pbigstring_load_64 of bool
+ | Pbigstring_set_16 of bool
+ | Pbigstring_set_32 of bool
+ | Pbigstring_set_64 of bool
+ (* Compile time constants *)
+ | Pctconst of compile_time_constant
+ (* byte swap *)
+ | Pbswap16
+ | Pbbswap of boxed_integer
and comparison =
Ceq | Cneq | Clt | Cgt | Cle | Cge
Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
name_list [] args
-let rec iter f = function
+let iter f = function
Lvar _
| Lconst _ -> ()
| Lapply(fn, args, _) ->
(* *)
(***********************************************************************)
-(* $Id: lambda.mli 12070 2012-01-23 14:49:39Z lefessan $ *)
-
(* The "lambda" intermediate code *)
open Asttypes
+type compile_time_constant =
+ | Big_endian
+ | Word_size
+ | Ostype_unix
+ | Ostype_win32
+ | Ostype_cygwin
+
type primitive =
Pidentity
| Pignore
(* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
| Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
| Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
+ (* size of the nth dimension of a big array *)
+ | Pbigarraydim of int
+ (* load/set 16,32,64 bits from a string: (unsafe)*)
+ | Pstring_load_16 of bool
+ | Pstring_load_32 of bool
+ | Pstring_load_64 of bool
+ | Pstring_set_16 of bool
+ | Pstring_set_32 of bool
+ | Pstring_set_64 of bool
+ (* load/set 16,32,64 bits from a
+ (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
+ | Pbigstring_load_16 of bool
+ | Pbigstring_load_32 of bool
+ | Pbigstring_load_64 of bool
+ | Pbigstring_set_16 of bool
+ | Pbigstring_set_32 of bool
+ | Pbigstring_set_64 of bool
+ (* Compile time constants *)
+ | Pctconst of compile_time_constant
+ (* byte swap *)
+ | Pbswap16
+ | Pbbswap of boxed_integer
and comparison =
Ceq | Cneq | Clt | Cgt | Cle | Cge
(* *)
(***********************************************************************)
-(* $Id: matching.ml 12961 2012-09-27 13:30:07Z garrigue $ *)
-
(* Compilation of pattern matching *)
open Misc
(*
- Many functions on the various data structures ofthe algorithm :
+ Many functions on the various data structures of the algorithm :
- Pattern matrices.
- Default environments: mapping from matrices to exit numbers.
- Contexts: matrices whose column are partitioned into
left and right.
- - Jump sumaries: mapping from exit numbers to contexts
+ - Jump summaries: mapping from exit numbers to contexts
*)
type matrix = pattern list list
let ctx_matcher p =
let p = normalize_pat p in
match p.pat_desc with
- | Tpat_construct (_, _, cstr,omegas,_) ->
+ | Tpat_construct (_, cstr,omegas,_) ->
(fun q rem -> match q.pat_desc with
- | Tpat_construct (_, _, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag ->
+ | Tpat_construct (_, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag ->
p,args @ rem
| Tpat_any -> p,omegas @ rem
| _ -> raise NoMatch)
(fun q rem -> match q.pat_desc with
| Tpat_record (l',_) ->
let l' = all_record_args l' in
- p, List.fold_right (fun (_, _, _,p) r -> p::r) l' rem
- | _ -> p,List.fold_right (fun (_, _, _,p) r -> p::r) l rem)
+ p, List.fold_right (fun (_, _,p) r -> p::r) l' rem
+ | _ -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem)
| Tpat_lazy omega ->
(fun q rem -> match q.pat_desc with
| Tpat_lazy arg -> p, (arg::rem)
pss)
ctx
-type jumps = (int * ctx ) list
+type jumps = (int * ctx list) list
-let pretty_jumps env = match env with
+let pretty_jumps (env : jumps) = match env with
| [] -> ()
| _ ->
List.iter
| [env] -> env
| _ -> jumps_unions (merge envs)
-let rec jumps_map f env =
+let jumps_map f env =
List.map
(fun (i,pss) -> i,f pss)
env
with
| Var p -> p
-let rec simplify_cases args cls = match args with
+let simplify_cases args cls = match args with
| [] -> assert false
| (arg,_)::_ ->
let rec simplify = function
List.fold_left extract_vars r pats
| Tpat_record (lpats,_) ->
List.fold_left
- (fun r (_, _, _, p) -> extract_vars r p)
+ (fun r (_, _, p) -> extract_vars r p)
r lpats
-| Tpat_construct (_, _, _, pats,_) ->
+| Tpat_construct (_, _, pats,_) ->
List.fold_left extract_vars r pats
| Tpat_array pats ->
List.fold_left extract_vars r pats
| _ -> false
and group_constructor = function
- | {pat_desc = Tpat_construct (_, _, _, _,_)} -> true
+ | {pat_desc = Tpat_construct _} -> true
| _ -> false
and group_variant = function
let get_group p = match p.pat_desc with
| Tpat_any -> group_var
| Tpat_constant _ -> group_constant
-| Tpat_construct (_, _, _, _, _) -> group_constructor
+| Tpat_construct _ -> group_constructor
| Tpat_tuple _ -> group_tuple
| Tpat_record _ -> group_record
| Tpat_array _ -> group_array
in make_args first_pos
let get_key_constr = function
- | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr.cstr_tag
+ | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr.cstr_tag
| _ -> assert false
let get_args_constr p rem = match p with
-| {pat_desc=Tpat_construct (_, _, _, args, _)} -> args @ rem
+| {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem
| _ -> assert false
let pat_as_constr = function
- | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr
+ | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr
| _ -> fatal_error "Matching.pat_as_constr"
with
| NoMatch -> matcher_rec p2 rem
end
- | Tpat_construct (_, _, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag ->
+ | Tpat_construct (_, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag ->
rem
| Tpat_any -> rem
| _ -> raise NoMatch in
rem
| _, _ -> assert false
end
- | Tpat_construct (_, _, cstr1, [arg],_)
+ | Tpat_construct (_, cstr1, [arg],_)
when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem
| Tpat_any -> omega::rem
| _ -> raise NoMatch in
| _ ->
fun q rem -> match q.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
- | Tpat_construct (_, _, cstr1, args,_)
+ | Tpat_construct (_, cstr1, args,_)
when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
| Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
| _ -> raise NoMatch
match Env.lookup_value (Longident.Lident field) env with
| (Path.Pdot(_,_,i), _) -> i
| _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
- with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.")
+ with Not_found ->
+ fatal_error ("Primitive "^modname^"."^field^" not found.")
in
Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
with Not_found -> fatal_error ("Module "^modname^" unavailable.")
(Lswitch
(varg,
{ sw_numconsts = 0; sw_consts = [];
- sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
+ sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *)
sw_blocks =
[ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
(Obj.lazy_tag,
Lapply(force_fun, [varg], loc)) ];
sw_failaction = Some varg } ))))
-let inline_lazy_force =
+let inline_lazy_force arg loc =
if !Clflags.native_code then
(* Lswitch generates compact and efficient native code *)
- inline_lazy_force_switch
+ inline_lazy_force_switch arg loc
else
(* generating bytecode: Lswitch would generate too many rather big
tables (~ 250 elts); conditionals are better *)
- inline_lazy_force_cond
+ inline_lazy_force_cond arg loc
let make_lazy_matching def = function
[] -> fatal_error "Matching.make_lazy_matching"
let record_matching_line num_fields lbl_pat_list =
let patv = Array.create num_fields omega in
- List.iter (fun (_, _, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
+ List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
Array.to_list patv
let get_args_record num_fields p rem = match p with
(cur_low,i-1,0)::
nofail_rec i i index rem in
- let rec init_rec = function
+ let init_rec = function
| [] -> []
| (i,act_i)::rem ->
let index = store.act_store act_i in
| Alias,_ -> lower_bind v arg lam
| _,_ -> bind str v arg lam
-let rec comp_exit ctx m = match m.default with
+let comp_exit ctx m = match m.default with
| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx
| _ -> fatal_error "Matching.comp_exit"
Output: a lambda term, a jump summary {..., exit number -> context, .. }
*)
+let dbg = false
let rec compile_match repr partial ctx m = match m with
| { cases = [] } -> comp_exit ctx m
{ m with args = (newarg, Alias) :: argl } in
let (lam, total) =
comp_match_handlers
- (do_compile_matching repr) partial ctx newarg first_match rem in
+ ((if dbg then do_compile_matching_pr else do_compile_matching) repr)
+ partial ctx newarg first_match rem in
bind_check str v arg lam, total
| _ -> assert false
(* verbose version of do_compile_matching, for debug *)
-(*
+
and do_compile_matching_pr repr partial ctx arg x =
prerr_string "COMPILE: " ;
prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ;
prerr_endline "JUMPS" ;
pretty_jumps jumps ;
r
-*)
+
and do_compile_matching repr partial ctx arg pmh = match pmh with
| Pm pm ->
let pat = what_is_cases pm.cases in
compile_no_test
(divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
repr partial ctx pm
- | Tpat_record ((_, _, lbl,_)::_,_) ->
+ | Tpat_record ((_, lbl,_)::_,_) ->
compile_no_test
(divide_record lbl.lbl_all (normalize_pat pat))
ctx_combine repr partial ctx pm
divide_constant
(combine_constant arg cst partial)
ctx pm
- | Tpat_construct (_, _, cstr, _, _) ->
+ | Tpat_construct (_, cstr, _, _) ->
compile_test
(compile_match repr partial) partial
divide_constructor (combine_constructor arg pat cstr partial)
(* The entry points *)
(*
- If there is a guard in a matching, then
- set exhaustiveness info to Partial.
- (because of side effects in guards, assume the worst)
+ If there is a guard in a matching or a lazy pattern,
+ then set exhaustiveness info to Partial.
+ (because of side effects, assume the worst).
+
+ Notice that exhaustiveness information is trusted by the compiler,
+ that is, a match flagged as Total should not fail at runtime.
+ More specifically, for instance if match y with x::_ -> x uis flagged
+ total (as it happens during JoCaml compilation) then y cannot be []
+ at runtime. As a consequence, the static Total exhaustiveness information
+ have to to be downgraded to Partial, in the dubious cases where guards
+ or lazy pattern execute arbitrary code that may perform side effects
+ and change the subject values.
+LM:
+ Lazy pattern was PR #5992, initial patch by lwp25.
+ I have generalized teh patch, so as to also find mutable fields.
*)
-let check_partial pat_act_list partial =
- if
+let find_in_pat pred =
+ let rec find_rec p =
+ pred p.pat_desc ||
+ begin match p.pat_desc with
+ | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p ->
+ find_rec p
+ | Tpat_tuple ps|Tpat_construct (_,_,ps,_) | Tpat_array ps ->
+ List.exists find_rec ps
+ | Tpat_record (lpats,_) ->
+ List.exists
+ (fun (_, _, p) -> find_rec p)
+ lpats
+ | Tpat_or (p,q,_) ->
+ find_rec p || find_rec q
+ | Tpat_constant _ | Tpat_var _
+ | Tpat_any | Tpat_variant (_,None,_) -> false
+ end in
+ find_rec
+
+let is_lazy_pat = function
+ | Tpat_lazy _ -> true
+ | Tpat_alias _ | Tpat_variant _ | Tpat_record _
+ | Tpat_tuple _|Tpat_construct _ | Tpat_array _
+ | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any
+ -> false
+
+let is_lazy p = find_in_pat is_lazy_pat p
+
+let have_mutable_field p = match p with
+| Tpat_record (lps,_) ->
List.exists
- (fun (_,lam) -> is_guarded lam)
- pat_act_list
- then begin
- Partial
- end else
- partial
+ (fun (_,lbl,_) ->
+ match lbl.Types.lbl_mut with
+ | Mutable -> true
+ | Immutable -> false)
+ lps
+| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _
+| Tpat_tuple _|Tpat_construct _ | Tpat_array _
+| Tpat_or _
+| Tpat_constant _ | Tpat_var _ | Tpat_any
+ -> false
+
+let is_mutable p = find_in_pat have_mutable_field p
+
+(* Downgrade Total when
+ 1. Matching accesses some mutable fields;
+ 2. And there are guards or lazy patterns.
+*)
+let check_partial is_mutable is_lazy pat_act_list = function
+ | Partial -> Partial
+ | Total ->
+ if
+ List.exists
+ (fun (pats, lam) ->
+ is_mutable pats && (is_guarded lam || is_lazy pats))
+ pat_act_list
+ then Partial
+ else Total
+
+let check_partial_list =
+ check_partial (List.exists is_mutable) (List.exists is_lazy)
+let check_partial = check_partial is_mutable is_lazy
(* have toplevel handler when appropriate *)
(* Easy case since variables are available *)
let for_tupled_function loc paraml pats_act_list partial =
- let partial = check_partial pats_act_list partial in
+ let partial = check_partial_list pats_act_list partial in
let raise_num = next_raise_count () in
let omegas = [List.map (fun _ -> omega) paraml] in
let pm =
| Tpat_any -> omegas size::k
| Tpat_tuple args -> args::k
| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k)
-| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a useless
- binding, solves PR #3780 *)
+| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a
+ useless binding, solves PR #3780 *)
flatten_pat_line size p k
| _ -> fatal_error "Matching.flatten_pat_line"
default = flatten_def size pm.default}
-let rec flatten_precompiled size args pmh = match pmh with
+let flatten_precompiled size args pmh = match pmh with
| Pm pm -> Pm (flatten_pm size args pm)
| PmOr {body=b ; handlers=hs ; or_matrix=m} ->
PmOr
v,Lvar v
-let rec param_to_var param = match param with
+let param_to_var param = match param with
| Lvar v -> v,None
| _ -> Ident.create "match",Some param
(* *)
(***********************************************************************)
-(* $Id: matching.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Compilation of pattern-matching *)
open Typedtree
(* *)
(***********************************************************************)
-(* $Id: meta.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
external global_data : unit -> Obj.t array = "caml_get_global_data"
external realloc_global_data : int -> unit = "caml_realloc_global"
external static_alloc : int -> string = "caml_static_alloc"
(* *)
(***********************************************************************)
-(* $Id: meta.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* To control the runtime system and bytecode interpreter *)
external global_data : unit -> Obj.t array = "caml_get_global_data"
(* *)
(***********************************************************************)
-(* $Id: printinstr.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Pretty-print lists of instructions *)
open Format
(* *)
(***********************************************************************)
-(* $Id: printinstr.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Pretty-print lists of instructions *)
open Instruct
(* *)
(***********************************************************************)
-(* $Id: printlambda.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
-
open Format
open Asttypes
open Primitive
| Parraysetu _ -> fprintf ppf "array.unsafe_set"
| Parrayrefs _ -> fprintf ppf "array.get"
| Parraysets _ -> fprintf ppf "array.set"
+ | Pctconst c ->
+ let const_name = match c with
+ | Big_endian -> "big_endian"
+ | Word_size -> "word_size"
+ | Ostype_unix -> "ostype_unix"
+ | Ostype_win32 -> "ostype_win32"
+ | Ostype_cygwin -> "ostype_cygwin" in
+ fprintf ppf "sys.constant_%s" const_name
| Pisint -> fprintf ppf "isint"
| Pisout -> fprintf ppf "isout"
| Pbittest -> fprintf ppf "testbit"
print_bigarray "get" unsafe kind ppf layout
| Pbigarrayset(unsafe, n, kind, layout) ->
print_bigarray "set" unsafe kind ppf layout
+ | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
+ | Pstring_load_16(unsafe) ->
+ if unsafe then fprintf ppf "string.unsafe_get16"
+ else fprintf ppf "string.get16"
+ | Pstring_load_32(unsafe) ->
+ if unsafe then fprintf ppf "string.unsafe_get32"
+ else fprintf ppf "string.get32"
+ | Pstring_load_64(unsafe) ->
+ if unsafe then fprintf ppf "string.unsafe_get64"
+ else fprintf ppf "string.get64"
+ | Pstring_set_16(unsafe) ->
+ if unsafe then fprintf ppf "string.unsafe_set16"
+ else fprintf ppf "string.set16"
+ | Pstring_set_32(unsafe) ->
+ if unsafe then fprintf ppf "string.unsafe_set32"
+ else fprintf ppf "string.set32"
+ | Pstring_set_64(unsafe) ->
+ if unsafe then fprintf ppf "string.unsafe_set64"
+ else fprintf ppf "string.set64"
+ | Pbigstring_load_16(unsafe) ->
+ if unsafe then fprintf ppf "bigarray.array1.unsafe_get16"
+ else fprintf ppf "bigarray.array1.get16"
+ | Pbigstring_load_32(unsafe) ->
+ if unsafe then fprintf ppf "bigarray.array1.unsafe_get32"
+ else fprintf ppf "bigarray.array1.get32"
+ | Pbigstring_load_64(unsafe) ->
+ if unsafe then fprintf ppf "bigarray.array1.unsafe_get64"
+ else fprintf ppf "bigarray.array1.get64"
+ | Pbigstring_set_16(unsafe) ->
+ if unsafe then fprintf ppf "bigarray.array1.unsafe_set16"
+ else fprintf ppf "bigarray.array1.set16"
+ | Pbigstring_set_32(unsafe) ->
+ if unsafe then fprintf ppf "bigarray.array1.unsafe_set32"
+ else fprintf ppf "bigarray.array1.set32"
+ | Pbigstring_set_64(unsafe) ->
+ if unsafe then fprintf ppf "bigarray.array1.unsafe_set64"
+ else fprintf ppf "bigarray.array1.set64"
+ | Pbswap16 -> fprintf ppf "bswap16"
+ | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
let rec lam ppf = function
| Lvar id ->
(* *)
(***********************************************************************)
-(* $Id: printlambda.mli 12179 2012-02-21 17:41:02Z xleroy $ *)
-
open Lambda
open Format
(* *)
(***********************************************************************)
-(* $Id: runtimedef.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Values and functions known and/or provided by the runtime system *)
val builtin_exceptions: string array
(* *)
(***********************************************************************)
-(* $Id: simplif.ml 12174 2012-02-20 17:45:10Z xleroy $ *)
-
(* Elimination of useless Llet(Alias) bindings.
Also transform let-bound references into variables. *)
| Lfor(v, l1, l2, dir, l3) ->
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
| Lassign(v, l) -> Lassign(v, simplif l)
- | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
+ | Lsend(k, m, o, ll, loc) ->
+ Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
| Levent(l, ev) -> Levent(simplif l, ev)
| Lifused(v, l) -> Lifused (v,simplif l)
in
| Lfor(v, l1, l2, dir, l3) ->
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
| Lassign(v, l) -> Lassign(v, simplif l)
- | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
+ | Lsend(k, m, o, ll, loc) ->
+ Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
| Levent(l, ev) -> Levent(simplif l, ev)
| Lifused(v, l) ->
if count_var v > 0 then simplif l else lambda_unit
(* *)
(***********************************************************************)
-(* $Id: simplif.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Elimination of useless Llet(Alias) bindings.
Transformation of let-bound references into variables.
Simplification over staticraise/staticcatch constructs.
(* *)
(***********************************************************************)
-(* $Id: symtable.ml 12629 2012-06-21 15:55:03Z doligez $ *)
-
(* To assign numbers to globals and primitives *)
open Misc
(* Must use the unsafe String.set here because the block may be
a "fake" string as returned by Meta.static_alloc. *)
-let patch_int buff pos n =
- String.unsafe_set buff pos (Char.unsafe_chr n);
- String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
- String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
- String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
+let gen_patch_int str_set buff pos n =
+ str_set buff pos (Char.unsafe_chr n);
+ str_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
+ str_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
+ str_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
-let patch_object buff patchlist =
+let gen_patch_object str_set buff patchlist =
List.iter
(function
(Reloc_literal sc, pos) ->
- patch_int buff pos (slot_for_literal sc)
+ gen_patch_int str_set buff pos (slot_for_literal sc)
| (Reloc_getglobal id, pos) ->
- patch_int buff pos (slot_for_getglobal id)
+ gen_patch_int str_set buff pos (slot_for_getglobal id)
| (Reloc_setglobal id, pos) ->
- patch_int buff pos (slot_for_setglobal id)
+ gen_patch_int str_set buff pos (slot_for_setglobal id)
| (Reloc_primitive name, pos) ->
- patch_int buff pos (num_of_prim name))
+ gen_patch_int str_set buff pos (num_of_prim name))
patchlist
+let patch_object = gen_patch_object String.unsafe_set
+let ls_patch_object = gen_patch_object LongString.set
+
(* Translate structured constants *)
let rec transl_const = function
(* *)
(***********************************************************************)
-(* $Id: symtable.mli 11306 2011-12-13 17:50:08Z frisch $ *)
-
(* Assign locations and numbers to globals and primitives *)
open Cmo_format
val init: unit -> unit
val patch_object: string -> (reloc_info * int) list -> unit
+val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit
val require_primitive: string -> unit
val initial_global_table: unit -> Obj.t array
val output_global_map: out_channel -> unit
(* *)
(***********************************************************************)
-(* $Id: translclass.ml 12518 2012-05-30 15:55:22Z lefessan $ *)
-
-open Misc
open Asttypes
open Types
open Typedtree
let transl_label l = share (Const_immstring l)
-let rec transl_meth_list lst =
+let transl_meth_list lst =
if lst = [] then Lconst (Const_pointer 0) else
share (Const_block
(0, List.map (fun lab -> Const_immstring lab) lst))
cl_init))
end
-let rec build_class_lets cl =
+let rec build_class_lets cl ids =
match cl.cl_desc with
- Tcl_let (rec_flag, defs, vals, cl) ->
- let env, wrap = build_class_lets cl in
- (env, fun x -> Translcore.transl_let rec_flag defs (wrap x))
+ Tcl_let (rec_flag, defs, vals, cl') ->
+ let env, wrap = build_class_lets cl' [] in
+ (env, fun x ->
+ let lam = Translcore.transl_let rec_flag defs (wrap x) in
+ (* Check recursion in toplevel let-definitions *)
+ if ids = [] || Translcore.check_recursive_lambda ids lam then lam
+ else raise(Error(cl.cl_loc, Illegal_class_expr)))
| _ ->
(cl.cl_env, fun x -> x)
let tables = Ident.create (Ident.name cl_id ^ "_tables") in
let (top_env, req) = oo_add_class tables in
let top = not req in
- let cl_env, llets = build_class_lets cl in
+ let cl_env, llets = build_class_lets cl ids in
let new_ids = if top then [] else Env.diff top_env cl_env in
let env2 = Ident.create "env" in
let meth_ids = get_class_meths cl in
let cla = Ident.create "class" in
let (inh_init, obj_init) =
build_object_init_0 cla [] cl copy_env subst_env top ids in
- if not (Translcore.check_recursive_lambda ids obj_init) then
- raise(Error(cl.cl_loc, Illegal_class_expr));
let inh_init' = List.rev inh_init in
let (inh_init', cl_init) =
build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
let report_error ppf = function
| Illegal_class_expr ->
- fprintf ppf "This kind of class expression is not allowed"
+ fprintf ppf "This kind of recursive class expression is not allowed"
| Tags (lab1, lab2) ->
fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
lab1 lab2 "Change one of them."
(* *)
(***********************************************************************)
-(* $Id: translclass.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Typedtree
open Lambda
(* *)
(***********************************************************************)
-(* $Id: translcore.ml 12871 2012-08-21 07:14:03Z lefessan $ *)
-
(* Translation from typed abstract syntax to lambda terms,
for the core language *)
open Misc
open Asttypes
open Primitive
-open Path
open Types
open Typedtree
open Typeopt
"%sequand", Psequand;
"%sequor", Psequor;
"%boolnot", Pnot;
+ "%big_endian", Pctconst Big_endian;
+ "%word_size", Pctconst Word_size;
+ "%ostype_unix", Pctconst Ostype_unix;
+ "%ostype_win32", Pctconst Ostype_win32;
+ "%ostype_cygwin", Pctconst Ostype_cygwin;
"%negint", Pnegint;
"%succint", Poffsetint 1;
"%predint", Poffsetint(-1);
"%caml_ba_unsafe_set_2",
Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
"%caml_ba_unsafe_set_3",
- Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)
+ Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
+ "%caml_ba_dim_1", Pbigarraydim(1);
+ "%caml_ba_dim_2", Pbigarraydim(2);
+ "%caml_ba_dim_3", Pbigarraydim(3);
+ "%caml_string_get16", Pstring_load_16(false);
+ "%caml_string_get16u", Pstring_load_16(true);
+ "%caml_string_get32", Pstring_load_32(false);
+ "%caml_string_get32u", Pstring_load_32(true);
+ "%caml_string_get64", Pstring_load_64(false);
+ "%caml_string_get64u", Pstring_load_64(true);
+ "%caml_string_set16", Pstring_set_16(false);
+ "%caml_string_set16u", Pstring_set_16(true);
+ "%caml_string_set32", Pstring_set_32(false);
+ "%caml_string_set32u", Pstring_set_32(true);
+ "%caml_string_set64", Pstring_set_64(false);
+ "%caml_string_set64u", Pstring_set_64(true);
+ "%caml_bigstring_get16", Pbigstring_load_16(false);
+ "%caml_bigstring_get16u", Pbigstring_load_16(true);
+ "%caml_bigstring_get32", Pbigstring_load_32(false);
+ "%caml_bigstring_get32u", Pbigstring_load_32(true);
+ "%caml_bigstring_get64", Pbigstring_load_64(false);
+ "%caml_bigstring_get64u", Pbigstring_load_64(true);
+ "%caml_bigstring_set16", Pbigstring_set_16(false);
+ "%caml_bigstring_set16u", Pbigstring_set_16(true);
+ "%caml_bigstring_set32", Pbigstring_set_32(false);
+ "%caml_bigstring_set32u", Pbigstring_set_32(true);
+ "%caml_bigstring_set64", Pbigstring_set_64(false);
+ "%caml_bigstring_set64u", Pbigstring_set_64(true);
+ "%bswap16", Pbswap16;
+ "%bswap_int32", Pbbswap(Pint32);
+ "%bswap_int64", Pbbswap(Pint64);
+ "%bswap_native", Pbbswap(Pnativeint);
]
let prim_makearray =
simplify_constant_constructor) =
Hashtbl.find comparisons_table prim_name in
begin match args with
- [arg1; {exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}]
+ [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}]
when simplify_constant_constructor ->
intcomp
- | [{exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}; arg2]
+ | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}; arg2]
when simplify_constant_constructor ->
intcomp
| [arg1; {exp_desc = Texp_variant(_, None)}]
match prim with
Plazyforce ->
let parm = Ident.create "prim" in
- Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none)
+ Lfunction(Curried, [parm],
+ Matching.inline_lazy_force (Lvar parm) Location.none)
| _ ->
let rec make_params n =
if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
let params = make_params p.prim_arity in
- Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))
+ Lfunction(Curried, params,
+ Lprim(prim, List.map (fun id -> Lvar id) params))
(* To check the well-formedness of r.h.s. of "let rec" definitions *)
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = Ident.create "obj" and meth = Ident.create "meth" in
- Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
+ Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [],
+ e.exp_loc))
else if p.prim_name = "%sendcache" then
let obj = Ident.create "obj" and meth = Ident.create "meth" in
let cache = Ident.create "cache" and pos = Ident.create "pos" in
Lfunction(Curried, [obj; meth; cache; pos],
- Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
+ Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos],
+ e.exp_loc))
else
transl_primitive e.exp_loc p
| Texp_ident(path, _, {val_kind = Val_anc _}) ->
transl_function e.exp_loc !Clflags.native_code repr partial pl)
in
Lfunction(kind, params, body)
- | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs)
+ | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn,
+ oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
let args, args' = cut p.prim_arity oargs in
in
let wrap0 f =
if args' = [] then f else wrap f in
- let args = List.map (function _, Some x, _ -> x | _ -> assert false) args in
+ let args =
+ List.map (function _, Some x, _ -> x | _ -> assert false) args in
let argl = transl_list args in
let public_send = p.prim_name = "%send"
|| not !Clflags.native_code && p.prim_name = "%sendcache"in
wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
| _ -> assert false
else begin
+ if p.prim_name = "%sequand" && Path.last path = "&" then
+ Location.prerr_warning fn.exp_loc
+ (Warnings.Deprecated "operator (&); you should use (&&) instead");
+ if p.prim_name = "%sequor" && Path.last path = "or" then
+ Location.prerr_warning fn.exp_loc
+ (Warnings.Deprecated "operator (or); you should use (||) instead");
let prim = transl_prim e.exp_loc p args in
match (prim, args) with
(Praise, [arg1]) ->
with Not_constant ->
Lprim(Pmakeblock(0, Immutable), ll)
end
- | Texp_construct(_, _, cstr, args, _) ->
+ | Texp_construct(_, cstr, args, _) ->
let ll = transl_list args in
begin match cstr.cstr_tag with
Cstr_constant n ->
Lprim(Pmakeblock(0, Immutable),
[Lconst(Const_base(Const_int tag)); lam])
end
- | Texp_record ((_, _, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
+ | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
| Texp_record ([], _) ->
fatal_error "Translcore.transl_exp: bad Texp_record"
- | Texp_field(arg, _, _, lbl) ->
+ | Texp_field(arg, _, lbl) ->
let access =
match lbl.lbl_repres with
Record_regular -> Pfield lbl.lbl_pos
| Record_float -> Pfloatfield lbl.lbl_pos in
Lprim(access, [transl_exp arg])
- | Texp_setfield(arg, _, _, lbl, newval) ->
+ | Texp_setfield(arg, _, lbl, newval) ->
let access =
match lbl.lbl_repres with
Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
( Const_int _ | Const_char _ | Const_string _
| Const_int32 _ | Const_int64 _ | Const_nativeint _ )
| Texp_function(_, _, _)
- | Texp_construct (_, _, {cstr_arity = 0}, _, _)
+ | Texp_construct (_, {cstr_arity = 0}, _, _)
-> transl_exp e
| Texp_constant(Const_float _) ->
Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
done
end;
List.iter
- (fun (_, _, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
+ (fun (_, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
lbl_expr_list;
let ll = Array.to_list lv in
let mut =
- if List.exists (fun (_, _, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
+ if List.exists (fun (_, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
then Mutable
else Immutable in
let lam =
(* If you change anything here, you will likely have to change
[check_recursive_recordwith] in this file. *)
let copy_id = Ident.create "newrecord" in
- let rec update_field (_, _, lbl, expr) cont =
+ let update_field (_, lbl, expr) cont =
let upd =
match lbl.lbl_repres with
Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
(* *)
(***********************************************************************)
-(* $Id: translcore.mli 12871 2012-08-21 07:14:03Z lefessan $ *)
-
(* Translation from typed abstract syntax to lambda terms,
for the core language *)
open Asttypes
-open Types
open Typedtree
open Lambda
(* *)
(***********************************************************************)
-(* $Id: translmod.ml 12871 2012-08-21 07:14:03Z lefessan $ *)
-
(* Translation from typed abstract syntax to lambda terms,
for the module language *)
open Path
open Types
open Typedtree
-open Primitive
open Lambda
open Translobj
open Translcore
let primitive_declarations = ref ([] : Primitive.description list)
let record_primitive = function
- | {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations
+ | {val_kind=Val_prim p} ->
+ primitive_declarations := p :: !primitive_declarations
| _ -> ()
(* Keep track of the root path (from the root of the namespace to the
bindings))
cont
+(* Extract the list of "value" identifiers bound by a signature.
+ "Value" identifiers are identifiers for signature components that
+ correspond to a run-time value: values, exceptions, modules, classes.
+ Note: manifest primitives do not correspond to a run-time value! *)
+
+let rec bound_value_identifiers = function
+ [] -> []
+ | Sig_value(id, {val_kind = Val_reg}) :: rem ->
+ id :: bound_value_identifiers rem
+ | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
+ | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
+ | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
+ | _ :: rem -> bound_value_identifiers rem
(* Compile a module expression *)
transl_module Tcoerce_none (field_path rootpath id) modl,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_recmodule bindings ->
- let ext_fields = List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in
+ let ext_fields =
+ List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in
compile_recmodule
(fun id modl ->
transl_module Tcoerce_none (field_path rootpath id) modl)
(transl_structure ext_fields cc rootpath rem)
| Tstr_modtype(id, _, decl) ->
transl_structure fields cc rootpath rem
- | Tstr_open (path, _) ->
+ | Tstr_open _ ->
transl_structure fields cc rootpath rem
| Tstr_class cl_list ->
let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in
transl_structure (List.rev ids @ fields) cc rootpath rem)
| Tstr_class_type cl_list ->
transl_structure fields cc rootpath rem
- | Tstr_include(modl, ids) ->
+ | Tstr_include(modl, sg) ->
+ let ids = bound_value_identifiers sg in
let mid = Ident.create "include" in
let rec rebind_idents pos newfields = function
[] ->
[transl_label_init
(transl_struct [] cc (global_path module_id) str)])
+
+(* Build the list of value identifiers defined by a toplevel structure
+ (excluding primitive declarations). *)
+
+let rec defined_idents = function
+ [] -> []
+ | item :: rem ->
+ match item.str_desc with
+ | Tstr_eval expr -> defined_idents rem
+ | Tstr_value(rec_flag, pat_expr_list) ->
+ let_bound_idents pat_expr_list @ defined_idents rem
+ | Tstr_primitive(id, _, descr) -> defined_idents rem
+ | Tstr_type decls -> defined_idents rem
+ | Tstr_exception(id, _, decl) -> id :: defined_idents rem
+ | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem
+ | Tstr_module(id, _, modl) -> id :: defined_idents rem
+ | Tstr_recmodule decls ->
+ List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem
+ | Tstr_modtype(id, _, decl) -> defined_idents rem
+ | Tstr_open _ -> defined_idents rem
+ | Tstr_class cl_list ->
+ List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem
+ | Tstr_class_type cl_list -> defined_idents rem
+ | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem
+
+(* second level idents (module M = struct ... let id = ... end),
+ and all sub-levels idents *)
+let rec more_idents = function
+ [] -> []
+ | item :: rem ->
+ match item.str_desc with
+ | Tstr_eval expr -> more_idents rem
+ | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem
+ | Tstr_primitive(id, _, descr) -> more_idents rem
+ | Tstr_type decls -> more_idents rem
+ | Tstr_exception(id, _, decl) -> more_idents rem
+ | Tstr_exn_rebind(id, _, path, _) -> more_idents rem
+ | Tstr_recmodule decls -> more_idents rem
+ | Tstr_modtype(id, _, decl) -> more_idents rem
+ | Tstr_open _ -> more_idents rem
+ | Tstr_class cl_list -> more_idents rem
+ | Tstr_class_type cl_list -> more_idents rem
+ | Tstr_include(modl, _) -> more_idents rem
+ | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
+ all_idents str.str_items @ more_idents rem
+ | Tstr_module(id, _, _) -> more_idents rem
+
+and all_idents = function
+ [] -> []
+ | item :: rem ->
+ match item.str_desc with
+ | Tstr_eval expr -> all_idents rem
+ | Tstr_value(rec_flag, pat_expr_list) ->
+ let_bound_idents pat_expr_list @ all_idents rem
+ | Tstr_primitive(id, _, descr) -> all_idents rem
+ | Tstr_type decls -> all_idents rem
+ | Tstr_exception(id, _, decl) -> id :: all_idents rem
+ | Tstr_exn_rebind(id, _, path, _) -> id :: all_idents rem
+ | Tstr_recmodule decls ->
+ List.map (fun (id, _, _, _) -> id) decls @ all_idents rem
+ | Tstr_modtype(id, _, decl) -> all_idents rem
+ | Tstr_open _ -> all_idents rem
+ | Tstr_class cl_list ->
+ List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem
+ | Tstr_class_type cl_list -> all_idents rem
+ | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem
+ | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
+ id :: all_idents str.str_items @ all_idents rem
+ | Tstr_module(id, _, _) -> id :: all_idents rem
+
+
(* A variant of transl_structure used to compile toplevel structure definitions
for the native-code compiler. Store the defined values in the fields
of the global as soon as they are defined, in order to reduce register
fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
let transl_store_structure glob map prims str =
- let rec transl_store subst = function
+ let rec transl_store rootpath subst = function
[] ->
transl_store_subst := subst;
lambda_unit
match item.str_desc with
| Tstr_eval expr ->
Lsequence(subst_lambda subst (transl_exp expr),
- transl_store subst rem)
+ transl_store rootpath subst rem)
| Tstr_value(rec_flag, pat_expr_list) ->
let ids = let_bound_idents pat_expr_list in
let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
Lsequence(subst_lambda subst lam,
- transl_store (add_idents false ids subst) rem)
+ transl_store rootpath (add_idents false ids subst) rem)
| Tstr_primitive(id, _, descr) ->
record_primitive descr.val_val;
- transl_store subst rem
+ transl_store rootpath subst rem
| Tstr_type(decls) ->
- transl_store subst rem
+ transl_store rootpath subst rem
| Tstr_exception( id, _, decl) ->
- let lam = transl_exception id (field_path (global_path glob) id) decl in
+ let lam = transl_exception id (field_path rootpath id) decl in
Lsequence(Llet(Strict, id, lam, store_ident id),
- transl_store (add_ident false id subst) rem)
+ transl_store rootpath (add_ident false id subst) rem)
| Tstr_exn_rebind( id, _, path, _) ->
let lam = subst_lambda subst (transl_path path) in
Lsequence(Llet(Strict, id, lam, store_ident id),
- transl_store (add_ident false id subst) rem)
+ transl_store rootpath (add_ident false id subst) rem)
+ | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
+ let lam = transl_store (field_path rootpath id) subst str.str_items in
+ (* Careful: see next case *)
+ let subst = !transl_store_subst in
+ Lsequence(lam,
+ Llet(Strict, id,
+ subst_lambda subst
+ (Lprim(Pmakeblock(0, Immutable),
+ List.map (fun id -> Lvar id)
+ (defined_idents str.str_items))),
+ Lsequence(store_ident id,
+ transl_store rootpath (add_ident true id subst)
+ rem)))
| Tstr_module( id, _, modl) ->
let lam =
- transl_module Tcoerce_none (field_path (global_path glob) id) modl in
+ transl_module Tcoerce_none (field_path rootpath id) modl in
(* Careful: the module value stored in the global may be different
from the local module value, in case a coercion is applied.
If so, keep using the local module value (id) in the remainder of
If not, we can use the value from the global
(add_ident true adds id -> Pgetglobal... to subst). *)
Llet(Strict, id, subst_lambda subst lam,
- Lsequence(store_ident id, transl_store(add_ident true id subst) rem))
+ Lsequence(store_ident id,
+ transl_store rootpath (add_ident true id subst) rem))
| Tstr_recmodule bindings ->
let ids = List.map fst4 bindings in
compile_recmodule
(fun id modl ->
subst_lambda subst
(transl_module Tcoerce_none
- (field_path (global_path glob) id) modl))
+ (field_path rootpath id) modl))
bindings
(Lsequence(store_idents ids,
- transl_store (add_idents true ids subst) rem))
+ transl_store rootpath (add_idents true ids subst) rem))
| Tstr_modtype(id, _, decl) ->
- transl_store subst rem
- | Tstr_open (path, _) ->
- transl_store subst rem
+ transl_store rootpath subst rem
+ | Tstr_open _ ->
+ transl_store rootpath subst rem
| Tstr_class cl_list ->
let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in
let lam =
cl_list,
store_idents ids) in
Lsequence(subst_lambda subst lam,
- transl_store (add_idents false ids subst) rem)
+ transl_store rootpath (add_idents false ids subst) rem)
| Tstr_class_type cl_list ->
- transl_store subst rem
- | Tstr_include(modl, ids) ->
+ transl_store rootpath subst rem
+ | Tstr_include(modl, sg) ->
+ let ids = bound_value_identifiers sg in
let mid = Ident.create "include" in
let rec store_idents pos = function
- [] -> transl_store (add_idents true ids subst) rem
+ [] -> transl_store rootpath (add_idents true ids subst) rem
| id :: idl ->
Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
Lsequence(store_ident id, store_idents (pos + 1) idl)) in
transl_primitive Location.none prim]),
cont)
- in List.fold_right store_primitive prims (transl_store !transl_store_subst str)
-
-(* Build the list of value identifiers defined by a toplevel structure
- (excluding primitive declarations). *)
-
-let rec defined_idents items =
- match items with
- [] -> []
- | item :: rem ->
- match item.str_desc with
- | Tstr_eval expr -> defined_idents rem
- | Tstr_value(rec_flag, pat_expr_list) ->
- let_bound_idents pat_expr_list @ defined_idents rem
- | Tstr_primitive(id, _, descr) -> defined_idents rem
- | Tstr_type decls -> defined_idents rem
- | Tstr_exception(id, _, decl) -> id :: defined_idents rem
- | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem
- | Tstr_module(id, _, modl) -> id :: defined_idents rem
- | Tstr_recmodule decls -> List.map fst4 decls @ defined_idents rem
- | Tstr_modtype(id, _, decl) -> defined_idents rem
- | Tstr_open (path, _) -> defined_idents rem
- | Tstr_class cl_list ->
- List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem
- | Tstr_class_type cl_list -> defined_idents rem
- | Tstr_include(modl, ids) -> ids @ defined_idents rem
+ in List.fold_right store_primitive prims
+ (transl_store (global_path glob) !transl_store_subst str)
(* Transform a coercion and the list of value identifiers defined by
a toplevel structure into a table [id -> (pos, coercion)],
Also compute the total size of the global block,
and the list of all primitives exported as values. *)
-let build_ident_map restr idlist =
+let build_ident_map restr idlist more_ids =
let rec natural_map pos map prims = function
[] ->
(map, prims, pos)
| id :: rem ->
natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in
- match restr with
- Tcoerce_none ->
- natural_map 0 Ident.empty [] idlist
- | Tcoerce_structure pos_cc_list ->
- let idarray = Array.of_list idlist in
- let rec export_map pos map prims undef = function
+ let (map, prims, pos) =
+ match restr with
+ Tcoerce_none ->
+ natural_map 0 Ident.empty [] idlist
+ | Tcoerce_structure pos_cc_list ->
+ let idarray = Array.of_list idlist in
+ let rec export_map pos map prims undef = function
[] ->
natural_map pos map prims undef
- | (source_pos, Tcoerce_primitive p) :: rem ->
- export_map (pos + 1) map ((pos, p) :: prims) undef rem
- | (source_pos, cc) :: rem ->
- let id = idarray.(source_pos) in
- export_map (pos + 1) (Ident.add id (pos, cc) map)
- prims (list_remove id undef) rem
- in export_map 0 Ident.empty [] idlist pos_cc_list
- | _ ->
- fatal_error "Translmod.build_ident_map"
+ | (source_pos, Tcoerce_primitive p) :: rem ->
+ export_map (pos + 1) map ((pos, p) :: prims) undef rem
+ | (source_pos, cc) :: rem ->
+ let id = idarray.(source_pos) in
+ export_map (pos + 1) (Ident.add id (pos, cc) map)
+ prims (list_remove id undef) rem
+ in export_map 0 Ident.empty [] idlist pos_cc_list
+ | _ ->
+ fatal_error "Translmod.build_ident_map"
+ in
+ natural_map pos map prims more_ids
(* Compile an implementation using transl_store_structure
(for the native-code compiler). *)
reset_labels ();
primitive_declarations := [];
let module_id = Ident.create_persistent module_name in
- let (map, prims, size) = build_ident_map restr (defined_idents str) in
+ let (map, prims, size) =
+ build_ident_map restr (defined_idents str) (more_idents str) in
let f = function
| [ { str_desc = Tstr_eval expr } ] when topl ->
assert (size = 0);
(make_sequence toploop_setvalue_id idents)
| Tstr_modtype(id, _, decl) ->
lambda_unit
- | Tstr_open (path, _) ->
+ | Tstr_open _ ->
lambda_unit
| Tstr_class cl_list ->
(* we need to use unique names for the classes because there might
cl_list)
| Tstr_class_type cl_list ->
lambda_unit
- | Tstr_include(modl, ids) ->
+ | Tstr_include(modl, sg) ->
+ let ids = bound_value_identifiers sg in
let mid = Ident.create "include" in
let rec set_idents pos = function
[] ->
let report_error ppf = function
Circular_dependency id ->
fprintf ppf
- "@[Cannot safely evaluate the definition@ of the recursively-defined module %a@]"
+ "@[Cannot safely evaluate the definition@ \
+ of the recursively-defined module %a@]"
Printtyp.ident id
(* *)
(***********************************************************************)
-(* $Id: translmod.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Translation from typed abstract syntax to lambda terms,
for the module language *)
(* *)
(***********************************************************************)
-(* $Id: translobj.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Misc
open Primitive
open Asttypes
(* *)
(***********************************************************************)
-(* $Id: translobj.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Lambda
val oo_prim: string -> lambda
(* *)
(***********************************************************************)
-(* $Id: typeopt.ml 11210 2011-09-22 09:05:42Z garrigue $ *)
-
(* Auxiliaries for type-based optimizations, e.g. array kinds *)
-open Misc
-open Asttypes
-open Primitive
open Path
open Types
open Typedtree
match scrape exp.exp_env exp.exp_type with
| Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
(bigarray_decode_type exp.exp_env elt_type kind_table Pbigarray_unknown,
- bigarray_decode_type exp.exp_env layout_type layout_table Pbigarray_unknown_layout)
+ bigarray_decode_type exp.exp_env layout_type layout_table
+ Pbigarray_unknown_layout)
| _ ->
(Pbigarray_unknown, Pbigarray_unknown_layout)
(* *)
(***********************************************************************)
-(* $Id: typeopt.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Auxiliaries for type-based optimizations, e.g. array kinds *)
val has_base_type : Typedtree.expression -> Path.t -> bool
prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
version.h
str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
- ../config/s.h mlvalues.h fail.h
+ ../config/s.h mlvalues.h fail.h int64_native.h
sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \
stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h
weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \
minor_gc.h
+win32.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \
+ ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+ osdeps.h signals.h sys.h
alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \
minor_gc.h stacks.h
prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
version.h
str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
- ../config/s.h mlvalues.h fail.h
+ ../config/s.h mlvalues.h fail.h int64_native.h
sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \
stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h
weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \
minor_gc.h
+win32.d.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \
+ ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+ osdeps.h signals.h sys.h
alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \
minor_gc.h stacks.h
prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
version.h
str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
- ../config/s.h mlvalues.h fail.h
+ ../config/s.h mlvalues.h fail.h int64_native.h
sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \
stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h
weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \
minor_gc.h
+win32.pic.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \
+ ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+ osdeps.h signals.h sys.h
# #
#########################################################################
-# $Id: Makefile 12566 2012-06-04 16:33:59Z doligez $
-
include Makefile.common
CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR)
# #
#########################################################################
-# $Id: Makefile.common 12265 2012-03-24 08:13:21Z xleroy $
-
include ../config/Makefile
CC=$(BYTECC)
cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A)
.PHONY: install-runtimed
+# If primitives contain duplicated lines (e.g. because the code is defined
+# like
+# #ifdef X
+# CAMLprim value caml_foo() ...
+# #else
+# CAMLprim value caml_foo() ...
+# end), horrible things will happen (duplicated entries in Runtimedef ->
+# double registration in Symtable -> empty entry in the PRIM table ->
+# the bytecode interpreter is confused).
+# We sort the primitive file and remove duplicates to avoid this problem.
+
+# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC
+# port, the "sort" program in the path is Microsoft's and not cygwin's
+
primitives : $(PRIMS)
- sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \
- $(PRIMS) > primitives
+ sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \
+ | sort | uniq > primitives
prims.c : primitives
(echo '#include "mlvalues.h"'; \
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
include Makefile.common
CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR)
DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
ocamlrun$(EXE): libcamlrun.$(A) prims.$(O)
- $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A)
+ $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) \
+ $(EXTRALIBS) libcamlrun.$(A)
ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O)
- $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A)
+ $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \
+ $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A)
libcamlrun.$(A): $(OBJS)
$(call MKLIB,libcamlrun.$(A),$(OBJS))
.depend.nt: .depend
rm -f .depend.win32
- echo "win32.o: win32.c fail.h compatibility.h misc.h config.h \\" >> .depend.win32
- echo " ../config/m.h ../config/s.h mlvalues.h memory.h gc.h \\" >> .depend.win32
- echo " major_gc.h freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32
+ echo "win32.o: win32.c fail.h compatibility.h \\" >> .depend.win32
+ echo " misc.h config.h ../config/m.h ../config/s.h \\" >> .depend.win32
+ echo " mlvalues.h memory.h gc.h major_gc.h \\" >> .depend.win32
+ echo " freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32
cat .depend >> .depend.win32
- sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' .depend.win32 > .depend.nt
+ sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \
+ .depend.win32 > .depend.nt
rm -f .depend.win32
include .depend.nt
/* */
/***********************************************************************/
-/* $Id: alloc.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* 1. Allocation functions doing the same work as the macros in the
case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
2. Convenience functions related to allocation.
/* */
/***********************************************************************/
-/* $Id: alloc.h 12000 2012-01-07 20:55:28Z lefessan $ */
-
#ifndef CAML_ALLOC_H
#define CAML_ALLOC_H
/* */
/***********************************************************************/
-/* $Id: array.c 11914 2011-12-21 10:41:59Z xleroy $ */
-
/* Operations on arrays */
#include <string.h>
count--, src++, pos++) {
caml_initialize(&Field(res, pos), *src);
}
- /* Many caml_initialize in a row can create a lot of old-to-young
- refs. Give the minor GC a chance to run if it needs to. */
- res = caml_check_urgent_gc(res);
}
Assert(pos == size);
+
+ /* Many caml_initialize in a row can create a lot of old-to-young
+ refs. Give the minor GC a chance to run if it needs to. */
+ res = caml_check_urgent_gc(res);
}
CAMLreturn (res);
}
/* */
/***********************************************************************/
-/* $Id: backtrace.c 12149 2012-02-10 16:15:24Z doligez $ */
-
/* Stack backtrace for uncaught exceptions */
+#include <fcntl.h>
#include <stdio.h>
#include <stdlib.h>
-#include <fcntl.h>
+#include <string.h>
+
#include "config.h"
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
+
#include "mlvalues.h"
#include "alloc.h"
#include "io.h"
}
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
if (pc >= caml_start_code && pc < end_code){
+ /* testing the code region is needed: PR#1554 */
caml_backtrace_buffer[caml_backtrace_pos++] = pc;
}
for (/*nothing*/; sp < caml_trapsp; sp++) {
}
}
+/* returns the next frame pointer (or NULL if none is available);
+ updates *sp to point to the following one, and *trapsp to the next
+ trap frame, which we will skip when we reach it */
+
+code_t caml_next_frame_pointer(value ** sp, value ** trapsp)
+{
+ code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
+
+ while (*sp < caml_stack_high) {
+ code_t *p = (code_t*) (*sp)++;
+ if(&Trap_pc(*trapsp) == p) {
+ *trapsp = Trap_link(*trapsp);
+ continue;
+ }
+ if (*p >= caml_start_code && *p < end_code) return *p;
+ }
+ return NULL;
+}
+
+/* Stores upto [max_frames_value] frames of the current call stack to
+ return to the user. This is used not in an exception-raising
+ context, but only when the user requests to save the trace
+ (hopefully less often). Instead of using a bounded buffer as
+ [caml_stash_backtrace], we first traverse the stack to compute the
+ right size, then allocate space for the trace. */
+
+CAMLprim value caml_get_current_callstack(value max_frames_value) {
+ CAMLparam1(max_frames_value);
+ CAMLlocal1(trace);
+
+ /* we use `intnat` here because, were it only `int`, passing `max_int`
+ from the OCaml side would overflow on 64bits machines. */
+ intnat max_frames = Long_val(max_frames_value);
+ intnat trace_size;
+
+ /* first compute the size of the trace */
+ {
+ value * sp = caml_extern_sp;
+ value * trapsp = caml_trapsp;
+
+ for (trace_size = 0; trace_size < max_frames; trace_size++) {
+ code_t p = caml_next_frame_pointer(&sp, &trapsp);
+ if (p == NULL) break;
+ }
+ }
+
+ trace = caml_alloc(trace_size, Abstract_tag);
+
+ /* then collect the trace */
+ {
+ value * sp = caml_extern_sp;
+ value * trapsp = caml_trapsp;
+ uintnat trace_pos;
+
+ for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
+ code_t p = caml_next_frame_pointer(&sp, &trapsp);
+ Assert(p != NULL);
+ /* The assignment below is safe without [caml_initialize], even
+ if the trace is large and allocated on the old heap, because
+ we assign values that are outside the OCaml heap. */
+ Assert(!(Is_block((value) p) && Is_in_heap((value) p)));
+ Field(trace, trace_pos) = (value) p;
+ }
+ }
+
+ CAMLreturn(trace);
+}
+
/* Read the debugging info contained in the current bytecode executable.
Return an OCaml array of OCaml lists of debug_event records in "events",
or Val_false on failure. */
#define O_BINARY 0
#endif
+static char *read_debug_info_error = "";
static value read_debug_info(void)
{
CAMLparam0();
exec_name = caml_exe_name;
}
fd = caml_attempt_open(&exec_name, &trail, 1);
- if (fd < 0) CAMLreturn(Val_false);
+ if (fd < 0){
+ read_debug_info_error = "executable program file not found";
+ CAMLreturn(Val_false);
+ }
caml_read_section_descriptors(fd, &trail);
if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
close(fd);
+ read_debug_info_error = "program not linked with -g";
CAMLreturn(Val_false);
}
chan = caml_open_descriptor_in(fd);
- Int_val (Field (ev_start, POS_BOL));
}
-/* Print location information */
+/* Print location information -- same behavior as in Printexc */
static void print_location(struct loc_info * li, int index)
{
events = read_debug_info();
if (events == Val_false) {
- fprintf(stderr,
- "(Program not linked with -g, cannot print stack backtrace)\n");
+ fprintf(stderr, "(Cannot print stack backtrace: %s)\n",
+ read_debug_info_error);
return;
}
for (i = 0; i < caml_backtrace_pos; i++) {
/* Convert the backtrace to a data structure usable from OCaml */
-CAMLprim value caml_get_exception_backtrace(value unit)
+CAMLprim value caml_convert_raw_backtrace(value backtrace)
{
- CAMLparam0();
+ CAMLparam1(backtrace);
CAMLlocal5(events, res, arr, p, fname);
int i;
struct loc_info li;
if (events == Val_false) {
res = Val_int(0); /* None */
} else {
- arr = caml_alloc(caml_backtrace_pos, 0);
- for (i = 0; i < caml_backtrace_pos; i++) {
- extract_location_info(events, caml_backtrace_buffer[i], &li);
+ arr = caml_alloc(Wosize_val(backtrace), 0);
+ for (i = 0; i < Wosize_val(backtrace); i++) {
+ extract_location_info(events, (code_t)Field(backtrace, i), &li);
if (li.loc_valid) {
fname = caml_copy_string(li.loc_filename);
p = caml_alloc_small(5, 0);
}
CAMLreturn(res);
}
+
+/* Get a copy of the latest backtrace */
+
+CAMLprim value caml_get_exception_raw_backtrace(value unit)
+{
+ CAMLparam0();
+ CAMLlocal1(res);
+ res = caml_alloc(caml_backtrace_pos, Abstract_tag);
+ if(caml_backtrace_buffer != NULL)
+ memcpy(&Field(res, 0), caml_backtrace_buffer,
+ caml_backtrace_pos * sizeof(code_t));
+ CAMLreturn(res);
+}
+
+/* the function below is deprecated: see asmrun/backtrace.c */
+
+CAMLprim value caml_get_exception_backtrace(value unit)
+{
+ CAMLparam0();
+ CAMLlocal2(raw, res);
+ raw = caml_get_exception_raw_backtrace(unit);
+ res = caml_convert_raw_backtrace(raw);
+ CAMLreturn(res);
+}
/* */
/***********************************************************************/
-/* $Id: backtrace.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_BACKTRACE_H
#define CAML_BACKTRACE_H
/* */
/***********************************************************************/
-/* $Id: callback.c 12149 2012-02-10 16:15:24Z doligez $ */
-
/* Callbacks from C to OCaml */
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: callback.h 12149 2012-02-10 16:15:24Z doligez $ */
-
/* Callbacks from C to OCaml */
#ifndef CAML_CALLBACK_H
/* */
/***********************************************************************/
-/* $Id: compact.c 12910 2012-09-10 09:52:09Z doligez $ */
-
#include <string.h>
#include "config.h"
/* */
/***********************************************************************/
-/* $Id: compact.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_COMPACT_H
#define CAML_COMPACT_H
/* */
/***********************************************************************/
-/* $Id: compare.c 12081 2012-01-26 14:13:51Z doligez $ */
-
#include <string.h>
#include <stdlib.h>
#include "custom.h"
/* */
/***********************************************************************/
-/* $Id: compare.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_COMPARE_H
#define CAML_COMPARE_H
/* */
/***********************************************************************/
-/* $Id: compatibility.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* definitions for compatibility with old identifiers */
#ifndef CAML_COMPATIBILITY_H
/* */
/***********************************************************************/
-/* $Id: config.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_CONFIG_H
#define CAML_CONFIG_H
/* We use threaded code interpretation if the compiler provides labels
as first-class values (GCC 2.x). */
-#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC) && !defined(CAML_JIT)
+#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \
+ && !defined (SHRINKED_GNUC) && !defined(CAML_JIT)
#define THREADED_CODE
#endif
/* */
/***********************************************************************/
-/* $Id: custom.c 12658 2012-07-06 16:44:24Z xleroy $ */
-
#include <string.h>
#include "alloc.h"
/* */
/***********************************************************************/
-/* $Id: custom.h 12000 2012-01-07 20:55:28Z lefessan $ */
-
#ifndef CAML_CUSTOM_H
#define CAML_CUSTOM_H
/* */
/***********************************************************************/
-/* $Id: debugger.c 12210 2012-03-08 19:52:03Z doligez $ */
-
/* Interface with the byte-code debugger */
#ifdef _WIN32
/* */
/***********************************************************************/
-/* $Id: debugger.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Interface with the debugger */
#ifndef CAML_DEBUGGER_H
/* */
/***********************************************************************/
-/* $Id: dynlink.c 12677 2012-07-09 14:15:48Z doligez $ */
-
/* Dynamic loading of C primitives. */
#include <stddef.h>
for (p = req_prims; *p != 0; p += strlen(p) + 1) {
c_primitive prim = lookup_primitive(p);
if (prim == NULL)
- caml_fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p);
+ caml_fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p);
caml_ext_table_add(&caml_prim_table, (void *) prim);
#ifdef DEBUG
caml_ext_table_add(&caml_prim_name_table, strdup(p));
for (i = 0; caml_builtin_cprim[i] != 0; i++) {
caml_ext_table_add(&caml_prim_table, (void *) caml_builtin_cprim[i]);
#ifdef DEBUG
- caml_ext_table_add(&caml_prim_name_table, strdup(caml_names_of_builtin_cprim[i]));
+ caml_ext_table_add(&caml_prim_name_table,
+ strdup(caml_names_of_builtin_cprim[i]));
#endif
}
}
/* */
/***********************************************************************/
-/* $Id: dynlink.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Dynamic loading of C primitives. */
#ifndef CAML_DYNLINK_H
/* */
/***********************************************************************/
-/* $Id: exec.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* exec.h : format of executable bytecode files */
#ifndef CAML_EXEC_H
/* */
/***********************************************************************/
-/* $Id: extern.c 12800 2012-07-30 18:59:07Z doligez $ */
-
/* Structured output */
/* The interface of this file is "intext.h" */
static uintnat size_32; /* Size in words of 32-bit block for struct. */
static uintnat size_64; /* Size in words of 64-bit block for struct. */
-static int extern_ignore_sharing; /* Flag to ignore sharing */
-static int extern_closures; /* Flag to allow externing code pointers */
+/* Flags affecting marshaling */
+
+enum {
+ NO_SHARING = 1, /* Flag to ignore sharing */
+ CLOSURES = 2, /* Flag to allow marshaling code pointers */
+ COMPAT_32 = 4 /* Flag to ensure that output can safely
+ be read back on a 32-bit platform */
+};
+
+static int extern_flags; /* logical or of some of the flags above */
/* Trail mechanism to undo forwarding pointers put inside objects */
{
header_t hdr;
- if (extern_ignore_sharing) return;
+ if (extern_flags & NO_SHARING) return;
if (extern_trail_cur == extern_trail_limit) {
struct trail_block * new_block = malloc(sizeof(struct trail_block));
if (new_block == NULL) extern_out_of_memory();
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
- } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
+ } else if (n < -((intnat)1 << 30) || n >= ((intnat)1 << 30)) {
+ if (extern_flags & COMPAT_32)
+ extern_failwith("output_value: integer cannot be read back on "
+ "32-bit platform");
writecode64(CODE_INT64, n);
#endif
} else
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
+#ifdef ARCH_SIXTYFOUR
+ if (len > 0xFFFFFB && (extern_flags & COMPAT_32))
+ extern_failwith("output_value: string cannot be read back on "
+ "32-bit platform");
+#endif
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
+#ifdef ARCH_SIXTYFOUR
+ if (nfloats > 0x1FFFFF && (extern_flags & COMPAT_32))
+ extern_failwith("output_value: float array cannot be read back on "
+ "32-bit platform");
+#endif
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
- extern_rec(v - Infix_offset_hd(hd));
- break;
+ v = v - Infix_offset_hd(hd); /* PR#5772 */
+ continue;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
+ /* Is this case useful? The overflow check in extern_value will fail.*/
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
+#ifdef ARCH_SIXTYFOUR
+ if (sz > 0x3FFFFF && (extern_flags & COMPAT_32))
+ extern_failwith("output_value: array cannot be read back on "
+ "32-bit platform");
+#endif
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
}
}
else if ((cf = extern_find_code((char *) v)) != NULL) {
- if (!extern_closures)
+ if ((extern_flags & CLOSURES) == 0)
extern_invalid_argument("output_value: functional value");
writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock((char *) cf->digest, 16);
/* Never reached as function leaves with return */
}
-enum { NO_SHARING = 1, CLOSURES = 2 };
-static int extern_flags[] = { NO_SHARING, CLOSURES };
+static int extern_flag_values[] = { NO_SHARING, CLOSURES, COMPAT_32 };
static intnat extern_value(value v, value flags)
{
intnat res_len;
- int fl;
/* Parse flag list */
- fl = caml_convert_flag_list(flags, extern_flags);
- extern_ignore_sharing = fl & NO_SHARING;
- extern_closures = fl & CLOSURES;
+ extern_flags = caml_convert_flag_list(flags, extern_flag_values);
/* Initializations */
init_extern_trail();
obj_counter = 0;
void caml_output_val(struct channel *chan, value v, value flags)
{
- intnat len;
struct output_block * blk, * nextblk;
if (! caml_channel_binary_mode(chan))
caml_failwith("output_value: not a binary channel");
init_extern_output();
- len = extern_value(v, flags);
+ extern_value(v, flags);
/* During [caml_really_putblock], concurrent [caml_output_val] operations
can take place (via signal handlers or context switching in systhreads),
and [extern_output_first] may change. So, save it in a local variable. */
/* */
/***********************************************************************/
-/* $Id: fail.c 11187 2011-09-08 08:34:43Z xclerc $ */
-
/* Raising exceptions from C. */
#include <stdio.h>
/* */
/***********************************************************************/
-/* $Id: fail.h 12000 2012-01-07 20:55:28Z lefessan $ */
-
#ifndef CAML_FAIL_H
#define CAML_FAIL_H
CAMLextern void caml_raise (value bucket) Noreturn;
CAMLextern void caml_raise_constant (value tag) Noreturn;
CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn;
-CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) Noreturn;
+CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[])
+ Noreturn;
CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn;
CAMLextern void caml_failwith (char const *) Noreturn;
CAMLextern void caml_invalid_argument (char const *) Noreturn;
/* */
/***********************************************************************/
-/* $Id: finalise.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Handling of finalised values. */
#include "callback.h"
/* */
/***********************************************************************/
-/* $Id: finalise.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_FINALISE_H
#define CAML_FINALISE_H
/* */
/***********************************************************************/
-/* $Id: fix_code.c 12715 2012-07-16 10:37:03Z frisch $ */
-
/* Handling of blocks of bytecode (endianness switch, threading). */
#include "config.h"
code_t caml_start_code;
asize_t caml_code_size;
unsigned char * caml_saved_code;
-unsigned char caml_code_md5[16];
/* Read the main bytecode block from a file */
/* */
/***********************************************************************/
-/* $Id: fix_code.h 12715 2012-07-16 10:37:03Z frisch $ */
-
/* Handling of blocks of bytecode (endianness switch, threading). */
#ifndef CAML_FIX_CODE_H
/* */
/***********************************************************************/
-/* $Id: floats.c 12030 2012-01-16 10:23:51Z frisch $ */
-
/* The interface of this file is in "mlvalues.h" and "alloc.h" */
#include <math.h>
/* */
/***********************************************************************/
-/* $Id: freelist.c 12910 2012-09-10 09:52:09Z doligez $ */
-
#define FREELIST_DEBUG 0
#if FREELIST_DEBUG
#include <stdio.h>
#if FREELIST_DEBUG
if (i > 5) fprintf (stderr, "FLP: found at %d size=%d\n", i, wo_sz);
#endif
- result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next(flp[i]));
+ result = allocate_block (Whsize_wosize (wo_sz), i, flp[i],
+ Next (flp[i]));
goto update_flp;
}
}
/* */
/***********************************************************************/
-/* $Id: freelist.h 12910 2012-09-10 09:52:09Z doligez $ */
-
/* Free lists of heap blocks. */
#ifndef CAML_FREELIST_H
/* */
/***********************************************************************/
-/* $Id: gc.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_GC_H
#define CAML_GC_H
/* */
/***********************************************************************/
-/* $Id: gc_ctrl.c 12708 2012-07-13 12:03:26Z doligez $ */
-
#include "alloc.h"
#include "compact.h"
#include "custom.h"
free_words = 0, free_blocks = 0, largest_free = 0,
fragments = 0, heap_chunks = 0;
char *chunk = caml_heap_start, *chunk_end;
- char *cur_hp, *prev_hp;
+ char *cur_hp;
+#ifdef DEBUG
+ char *prev_hp;
+#endif
header_t cur_hd;
#ifdef DEBUG
while (chunk != NULL){
++ heap_chunks;
chunk_end = chunk + Chunk_size (chunk);
+#ifdef DEBUG
prev_hp = NULL;
+#endif
cur_hp = chunk;
while (cur_hp < chunk_end){
cur_hd = Hd_hp (cur_hp);
*/
break;
}
+#ifdef DEBUG
prev_hp = cur_hp;
+#endif
cur_hp = Next (cur_hp);
} Assert (cur_hp == chunk_end);
chunk = Chunk_next (chunk);
/* Minor heap size comes last because it will trigger a minor collection
(thus invalidating [v]) and it can raise [Out_of_memory]. */
- newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0))));
+ newminsize = Bsize_wsize (norm_minsize (Long_val (Field (v, 0))));
if (newminsize != caml_minor_heap_size){
caml_gc_message (0x20, "New minor heap size: %luk bytes\n",
newminsize/1024);
/* */
/***********************************************************************/
-/* $Id: gc_ctrl.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_GC_CTRL_H
#define CAML_GC_CTRL_H
/* */
/***********************************************************************/
-/* $Id: globroots.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Registration of global memory roots */
#include "memory.h"
/* */
/***********************************************************************/
-/* $Id: globroots.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Registration of global memory roots */
#ifndef CAML_GLOBROOTS_H
/* */
/***********************************************************************/
-/* $Id: hash.c 12149 2012-02-10 16:15:24Z doligez $ */
-
/* The generic hashing primitive */
/* The interface of this file is in "mlvalues.h" (for [caml_hash_variant])
/* */
/***********************************************************************/
-/* $Id$ */
-
/* Auxiliary functions for custom hash functions */
#ifndef CAML_HASH_H
/* */
/***********************************************************************/
-/* $Id: instrtrace.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Trace the instructions executed */
#ifdef DEBUG
if (prog && v % sizeof (int) == 0
&& (code_t) v >= prog
&& (code_t) v < (code_t) ((char *) prog + proglen))
- fprintf (f, "=code@%d", (code_t) v - prog);
+ fprintf (f, "=code@%ld", (code_t) v - prog);
else if (Is_long (v))
fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v));
else if ((void*)v >= (void*)caml_stack_low
&& (void*)v < (void*)caml_stack_high)
- fprintf (f, "=stack_%d", (intnat*)caml_stack_high - (intnat*)v);
+ fprintf (f, "=stack_%ld", (intnat*)caml_stack_high - (intnat*)v);
else if (Is_block (v)) {
int s = Wosize_val (v);
int tg = Tag_val (v);
int l = 0;
switch (tg) {
case Closure_tag:
- fprintf (f, "=closure[s%d,cod%d]", s, (code_t) (Code_val (v)) - prog);
+ fprintf (f, "=closure[s%d,cod%ld]", s, (code_t) (Code_val (v)) - prog);
goto displayfields;
case String_tag:
l = caml_string_length (v);
value *p;
fprintf (f, "accu=");
caml_trace_value_file (accu, prog, proglen, f);
- fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%d:",
+ fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%ld:",
(intnat) sp, caml_stack_high - sp);
for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high;
p++, i++) {
- fprintf (f, "\n[%d] ", caml_stack_high - p);
+ fprintf (f, "\n[%ld] ", caml_stack_high - p);
caml_trace_value_file (*p, prog, proglen, f);
};
putc ('\n', f);
/* */
/***********************************************************************/
-/* $Id: instrtrace.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Trace the instructions executed */
#ifndef _instrtrace_
void caml_stop_here (void);
void caml_disasm_instr (code_t pc);
void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f);
-void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, FILE * f);
+void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen,
+ FILE * f);
#endif
/* */
/***********************************************************************/
-/* $Id: instruct.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The instruction set. */
#ifndef CAML_INSTRUCT_H
/* */
/***********************************************************************/
-/* $Id: int64_emul.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Software emulation of 64-bit integer arithmetic, for C compilers
that do not support it. */
return res;
}
+static int64 I64_bswap(int64 x)
+{
+ int64 res;
+ res.h = (((x.l & 0x000000FF) << 24) |
+ ((x.l & 0x0000FF00) << 8) |
+ ((x.l & 0x00FF0000) >> 8) |
+ ((x.l & 0xFF000000) >> 24));
+ res.l = (((x.h & 0x000000FF) << 24) |
+ ((x.h & 0x0000FF00) << 8) |
+ ((x.h & 0x00FF0000) >> 8) |
+ ((x.h & 0xFF000000) >> 24));
+ return res;
+}
+
#endif /* CAML_INT64_EMUL_H */
/* */
/***********************************************************************/
-/* $Id: int64_format.h 11180 2011-09-07 12:04:58Z xleroy $ */
-
/* printf-like formatting of 64-bit integers, in case the C library
printf() function does not support them. */
/* */
/***********************************************************************/
-/* $Id: int64_native.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Wrapper macros around native 64-bit integer arithmetic,
so that it has the same interface as the software emulation
provided in int64_emul.h */
#define I64_to_double(x) ((double)(x))
#define I64_of_double(x) ((int64)(x))
+#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \
+ (((x) & 0x000000000000FF00ULL) << 40) | \
+ (((x) & 0x0000000000FF0000ULL) << 24) | \
+ (((x) & 0x00000000FF000000ULL) << 8) | \
+ (((x) & 0x000000FF00000000ULL) >> 8) | \
+ (((x) & 0x0000FF0000000000ULL) >> 24) | \
+ (((x) & 0x00FF000000000000ULL) >> 40) | \
+ (((x) & 0xFF00000000000000ULL) >> 56))
+
#endif /* CAML_INT64_NATIVE_H */
/* */
/***********************************************************************/
-/* $Id: intern.c 12910 2012-09-10 09:52:09Z doligez $ */
-
/* Structured input, compact format */
/* The interface of this file is "intext.h" */
value caml_input_val(struct channel *chan)
{
uint32 magic;
- mlsize_t block_len, num_objects, size_32, size_64, whsize;
+ mlsize_t block_len, num_objects, whsize;
char * block;
value res;
if (magic != Intext_magic_number) caml_failwith("input_value: bad object");
block_len = caml_getword(chan);
num_objects = caml_getword(chan);
- size_32 = caml_getword(chan);
- size_64 = caml_getword(chan);
+#ifdef ARCH_SIXTYFOUR
+ caml_getword(chan); /* skip size_32 */
+ whsize = caml_getword(chan);
+#else
+ whsize = caml_getword(chan);
+ caml_getword(chan); /* skip size_64 */
+#endif
/* Read block from channel */
block = caml_stat_alloc(block_len);
/* During [caml_really_getblock], concurrent [caml_input_val] operations
intern_input = (unsigned char *) block;
intern_input_malloced = 1;
intern_src = intern_input;
- /* Allocate result */
-#ifdef ARCH_SIXTYFOUR
- whsize = size_64;
-#else
- whsize = size_32;
-#endif
intern_alloc(whsize, num_objects);
/* Fill it in */
intern_rec(&res);
/* Free everything */
caml_stat_free(intern_input);
if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
- return res;
+ return caml_check_urgent_gc(res);
}
CAMLprim value caml_input_value(value vchan)
CAMLexport value caml_input_val_from_string(value str, intnat ofs)
{
CAMLparam1 (str);
- mlsize_t num_objects, size_32, size_64, whsize;
+ mlsize_t num_objects, whsize;
CAMLlocal1 (obj);
intern_src = &Byte_u(str, ofs + 2*4);
intern_input_malloced = 0;
num_objects = read32u();
- size_32 = read32u();
- size_64 = read32u();
- /* Allocate result */
#ifdef ARCH_SIXTYFOUR
- whsize = size_64;
+ intern_src += 4; /* skip size_32 */
+ whsize = read32u();
#else
- whsize = size_32;
+ whsize = read32u();
+ intern_src += 4; /* skip size_64 */
#endif
+ /* Allocate result */
intern_alloc(whsize, num_objects);
intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */
/* Fill it in */
intern_add_to_heap(whsize);
/* Free everything */
if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
- CAMLreturn (obj);
+ CAMLreturn (caml_check_urgent_gc(obj));
}
CAMLprim value caml_input_value_from_string(value str, value ofs)
static value input_val_from_block(void)
{
- mlsize_t num_objects, size_32, size_64, whsize;
+ mlsize_t num_objects, whsize;
value obj;
num_objects = read32u();
- size_32 = read32u();
- size_64 = read32u();
- /* Allocate result */
#ifdef ARCH_SIXTYFOUR
- whsize = size_64;
+ intern_src += 4; /* skip size_32 */
+ whsize = read32u();
#else
- whsize = size_32;
+ whsize = read32u();
+ intern_src += 4; /* skip size_64 */
#endif
+ /* Allocate result */
intern_alloc(whsize, num_objects);
/* Fill it in */
intern_rec(&obj);
intern_add_to_heap(whsize);
/* Free internal data structures */
if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
- return obj;
+ return caml_check_urgent_gc(obj);
}
CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs)
{
uint32 magic;
- mlsize_t block_len;
value obj;
intern_input = (unsigned char *) data;
magic = read32u();
if (magic != Intext_magic_number)
caml_failwith("input_value_from_malloc: bad object");
- block_len = read32u();
+ intern_src += 4; /* Skip block_len */
obj = input_val_from_block();
/* Free the input */
caml_stat_free(intern_input);
static void intern_bad_code_pointer(unsigned char digest[16])
{
char msg[256];
- sprintf(msg, "input_value: unknown code module %02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X",
+ sprintf(msg, "input_value: unknown code module "
+ "%02X%02X%02X%02X%02X%02X%02X%02X"
+ "%02X%02X%02X%02X%02X%02X%02X%02X",
digest[0], digest[1], digest[2], digest[3],
digest[4], digest[5], digest[6], digest[7],
digest[8], digest[9], digest[10], digest[11],
/* */
/***********************************************************************/
-/* $Id: interp.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The bytecode interpreter */
#include <stdio.h>
#include "alloc.h"
For GCC, I have hand-assigned hardware registers for several architectures.
*/
-#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) && !defined(__llvm__)
+#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) \
+ && !defined(__llvm__)
#ifdef __mips__
#define PC_REG asm("$16")
#define SP_REG asm("$17")
struct caml__roots_block * volatile initial_local_roots;
volatile code_t saved_pc = NULL;
struct longjmp_buffer raise_buf;
- value * modify_dest, modify_newval;
#ifndef THREADED_CODE
opcode_t curr_instr;
#endif
}
Instruct(SETFIELD0):
- modify_dest = &Field(accu, 0);
- modify_newval = *sp++;
- modify:
- Modify(modify_dest, modify_newval);
+ caml_modify(&Field(accu, 0), *sp++);
accu = Val_unit;
Next;
Instruct(SETFIELD1):
- modify_dest = &Field(accu, 1);
- modify_newval = *sp++;
- goto modify;
+ caml_modify(&Field(accu, 1), *sp++);
+ accu = Val_unit;
+ Next;
Instruct(SETFIELD2):
- modify_dest = &Field(accu, 2);
- modify_newval = *sp++;
- goto modify;
+ caml_modify(&Field(accu, 2), *sp++);
+ accu = Val_unit;
+ Next;
Instruct(SETFIELD3):
- modify_dest = &Field(accu, 3);
- modify_newval = *sp++;
- goto modify;
+ caml_modify(&Field(accu, 3), *sp++);
+ accu = Val_unit;
+ Next;
Instruct(SETFIELD):
- modify_dest = &Field(accu, *pc);
+ caml_modify(&Field(accu, *pc), *sp++);
+ accu = Val_unit;
pc++;
- modify_newval = *sp++;
- goto modify;
+ Next;
Instruct(SETFLOATFIELD):
Store_double_field(accu, *pc, Double_val(*sp));
accu = Val_unit;
sp += 1;
Next;
Instruct(SETVECTITEM):
- modify_dest = &Field(accu, Long_val(sp[0]));
- modify_newval = sp[1];
+ caml_modify(&Field(accu, Long_val(sp[0])), sp[1]);
+ accu = Val_unit;
sp += 2;
- goto modify;
+ Next;
/* String operations */
#else
caml_fatal_error_arg("Fatal error: bad opcode (%"
ARCH_INTNAT_PRINTF_FORMAT "x)\n",
- (char *)(*(pc-1)));
+ (char *) (intnat) *(pc-1));
#endif
}
}
/* */
/***********************************************************************/
-/* $Id: interp.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The bytecode interpreter */
#ifndef CAML_INTERP_H
/* */
/***********************************************************************/
-/* $Id: intext.h 12227 2012-03-13 14:44:48Z xleroy $ */
-
/* Structured input/output */
#ifndef CAML_INTEXT_H
/* */
/***********************************************************************/
-/* $Id: ints.c 12149 2012-02-10 16:15:24Z doligez $ */
-
#include <stdio.h>
#include <string.h>
#include "alloc.h"
}
#endif
+value caml_bswap16_direct(value x)
+{
+ return ((((x & 0x00FF) << 8) |
+ ((x & 0xFF00) >> 8)));
+}
+
+CAMLprim value caml_bswap16(value v)
+{
+ intnat x = Int_val(v);
+ return (Val_int ((((x & 0x00FF) << 8) |
+ ((x & 0xFF00) >> 8))));
+}
+
/* Tagged integers */
CAMLprim value caml_int_compare(value v1, value v2)
CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2)
{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); }
+static int32 caml_swap32(int32 x)
+{
+ return (((x & 0x000000FF) << 24) |
+ ((x & 0x0000FF00) << 8) |
+ ((x & 0x00FF0000) >> 8) |
+ ((x & 0xFF000000) >> 24));
+}
+
+value caml_int32_direct_bswap(value v)
+{ return caml_swap32(v); }
+
+CAMLprim value caml_int32_bswap(value v)
+{ return caml_copy_int32(caml_swap32(Int32_val(v))); }
+
CAMLprim value caml_int32_of_int(value v)
{ return caml_copy_int32(Long_val(v)); }
CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2)
{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); }
+#ifdef ARCH_SIXTYFOUR
+static value caml_swap64(value x)
+{
+ return (((((x) & 0x00000000000000FF) << 56) |
+ (((x) & 0x000000000000FF00) << 40) |
+ (((x) & 0x0000000000FF0000) << 24) |
+ (((x) & 0x00000000FF000000) << 8) |
+ (((x) & 0x000000FF00000000) >> 8) |
+ (((x) & 0x0000FF0000000000) >> 24) |
+ (((x) & 0x00FF000000000000) >> 40) |
+ (((x) & 0xFF00000000000000) >> 56)));
+}
+
+value caml_int64_direct_bswap(value v)
+{ return caml_swap64(v); }
+#endif
+
+CAMLprim value caml_int64_bswap(value v)
+{ return caml_copy_int64(I64_bswap(Int64_val(v))); }
+
CAMLprim value caml_int64_of_int(value v)
{ return caml_copy_int64(I64_of_intnat(Long_val(v))); }
if (divisor == 0) caml_raise_zero_divide();
/* PR#4740: on some processors, modulus crashes if division overflows.
Implement the same behavior as for type "int". */
- if (dividend == Nativeint_min_int && divisor == -1) return caml_copy_nativeint(0);
+ if (dividend == Nativeint_min_int && divisor == -1){
+ return caml_copy_nativeint(0);
+ }
#ifdef NONSTANDARD_DIV_MOD
return caml_copy_nativeint(caml_safe_mod(dividend, divisor));
#else
CAMLprim value caml_nativeint_shift_right_unsigned(value v1, value v2)
{ return caml_copy_nativeint((uintnat)Nativeint_val(v1) >> Int_val(v2)); }
+value caml_nativeint_direct_bswap(value v)
+{
+#ifdef ARCH_SIXTYFOUR
+ return caml_swap64(v);
+#else
+ return caml_swap32(v);
+#endif
+}
+
+CAMLprim value caml_nativeint_bswap(value v)
+{
+#ifdef ARCH_SIXTYFOUR
+ return caml_copy_nativeint(caml_swap64(Nativeint_val(v)));
+#else
+ return caml_copy_nativeint(caml_swap32(Nativeint_val(v)));
+#endif
+}
+
CAMLprim value caml_nativeint_of_int(value v)
{ return caml_copy_nativeint(Long_val(v)); }
/* */
/***********************************************************************/
-/* $Id: io.c 12641 2012-06-25 12:02:16Z lefessan $ */
-
/* Buffered input/output. */
#include <errno.h>
/* */
/***********************************************************************/
-/* $Id: io.h 12331 2012-04-10 14:07:40Z doligez $ */
-
/* Buffered input/output */
#ifndef CAML_IO_H
/* */
/***********************************************************************/
-/* $Id: lexing.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The table-driven automaton for lexers generated by camllex. */
#include "fail.h"
else
pc_off = Short(tbl->lex_default_code, pstate) ;
if (pc_off > 0)
- run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ;
+ run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem,
+ lexbuf->lex_curr_pos) ;
/* Erase the EOF condition only if the EOF pseudo-character was
consumed by the automaton (i.e. there was no backtrack above)
*/
/* */
/***********************************************************************/
-/* $Id: main.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Main entry point (can be overridden by a user-provided main()
function that calls caml_main() later). */
int main(int argc, char **argv)
{
#ifdef DEBUG
+ caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
+#if 0
{
+ int i;
char *ocp;
char *cp;
- int i;
- caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
-#if 0
caml_gc_message (-1, "### command line:", 0);
for (i = 0; i < argc; i++){
caml_gc_message (-1, " %s", argv[i]);
cp = getenv ("CAMLRUNPARAM");
caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp);
caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0));
-#endif
}
#endif
+#endif
#ifdef _WIN32
/* Expand wildcards and diversions in command line */
caml_expand_command_line(&argc, &argv);
/* */
/***********************************************************************/
-/* $Id: major_gc.c 12910 2012-09-10 09:52:09Z doligez $ */
-
#include <limits.h>
#include "compact.h"
if (caml_page_table_add(In_heap, caml_heap_start,
caml_heap_start + caml_stat_heap_size) != 0) {
- caml_fatal_error ("Fatal error: not enough memory for the initial page table.\n");
+ caml_fatal_error ("Fatal error: not enough memory "
+ "for the initial page table.\n");
}
caml_fl_init_merge ();
/* */
/***********************************************************************/
-/* $Id: major_gc.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_MAJOR_GC_H
#define CAML_MAJOR_GC_H
/* */
/***********************************************************************/
-/* $Id: md5.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include <string.h>
#include "alloc.h"
#include "fail.h"
caml_MD5Transform(ctx->buf, (uint32 *) ctx->in);
byteReverse((unsigned char *) ctx->buf, 4);
memcpy(digest, ctx->buf, 16);
- memset(ctx, 0, sizeof(ctx)); /* In case it's sensitive */
+ memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */
}
/* The four core functions - F1 is optimized somewhat */
/* */
/***********************************************************************/
-/* $Id: md5.h 12800 2012-07-30 18:59:07Z doligez $ */
-
/* MD5 message digest */
#ifndef CAML_MD5_H
/* */
/***********************************************************************/
-/* $Id: memory.c 12910 2012-09-10 09:52:09Z doligez $ */
-
#include <stdlib.h>
#include <string.h>
#include "fail.h"
A block value [v] is a shared block if and only if [Is_in_heap (v)]
is true.
*/
-/* [caml_initialize] never calls the GC, so you may call it while an block is
+/* [caml_initialize] never calls the GC, so you may call it while a block is
unfinished (i.e. just after a call to [caml_alloc_shr].) */
-void caml_initialize (value *fp, value val)
+/* PR#6084 workaround: define it as a weak symbol */
+CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
{
+ CAMLassert(Is_in_heap(fp));
*fp = val;
- if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){
+ if (Is_block (val) && Is_young (val)) {
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
unless you are sure the value being overwritten is not a shared block and
the value being written is not a young block. */
/* [caml_modify] never calls the GC. */
-void caml_modify (value *fp, value val)
+/* [caml_modify] can also be used to do assignment on data structures that are
+ in the minor heap instead of in the major heap. In this case, it
+ is a bit slower than simple assignment.
+ In particular, you can use [caml_modify] when you don't know whether the
+ block being changed is in the minor heap or the major heap. */
+/* PR#6084 workaround: define it as a weak symbol */
+
+CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
{
- Modify (fp, val);
+ /* The write barrier implemented by [caml_modify] checks for the
+ following two conditions and takes appropriate action:
+ 1- a pointer from the major heap to the minor heap is created
+ --> add [fp] to the remembered set
+ 2- a pointer from the major heap to the major heap is overwritten,
+ while the GC is in the marking phase
+ --> call [caml_darken] on the overwritten pointer so that the
+ major GC treats it as an additional root.
+ */
+ value old;
+
+ if (Is_young((value)fp)) {
+ /* The modified object resides in the minor heap.
+ Conditions 1 and 2 cannot occur. */
+ *fp = val;
+ } else {
+ /* The modified object resides in the major heap. */
+ CAMLassert(Is_in_heap(fp));
+ old = *fp;
+ *fp = val;
+ if (Is_block(old)) {
+ /* If [old] is a pointer within the minor heap, we already
+ have a major->minor pointer and [fp] is already in the
+ remembered set. Conditions 1 and 2 cannot occur. */
+ if (Is_young(old)) return;
+ /* Here, [old] can be a pointer within the major heap.
+ Check for condition 2. */
+ if (caml_gc_phase == Phase_mark) caml_darken(old, NULL);
+ }
+ /* Check for condition 1. */
+ if (Is_block(val) && Is_young(val)) {
+ /* Add [fp] to remembered set */
+ if (caml_ref_table.ptr >= caml_ref_table.limit){
+ CAMLassert (caml_ref_table.ptr == caml_ref_table.limit);
+ caml_realloc_ref_table (&caml_ref_table);
+ }
+ *caml_ref_table.ptr++ = fp;
+ }
+ }
}
CAMLexport void * caml_stat_alloc (asize_t sz)
/* */
/***********************************************************************/
-/* $Id: memory.h 12210 2012-03-08 19:52:03Z doligez $ */
-
/* Allocation macros and functions */
#ifndef CAML_MEMORY_H
DEBUG_clear ((result), (wosize)); \
}while(0)
-/* You must use [Modify] to change a field of an existing shared block,
- unless you are sure the value being overwritten is not a shared block and
- the value being written is not a young block. */
-/* [Modify] never calls the GC. */
-/* [Modify] can also be used to do assignment on data structures that are
- not in the (major) heap. In this case, it is a bit slower than
- simple assignment.
- In particular, you can use [Modify] when you don't know whether the
- block being changed is in the minor heap or the major heap.
-*/
+/* Deprecated alias for [caml_modify] */
-#define Modify(fp, val) do{ \
- value _old_ = *(fp); \
- *(fp) = (val); \
- if (Is_in_heap (fp)){ \
- if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL); \
- if (Is_block (val) && Is_young (val) \
- && ! (Is_block (_old_) && Is_young (_old_))){ \
- if (caml_ref_table.ptr >= caml_ref_table.limit){ \
- CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); \
- caml_realloc_ref_table (&caml_ref_table); \
- } \
- *caml_ref_table.ptr++ = (fp); \
- } \
- } \
-}while(0)
+#define Modify(fp,val) caml_modify((fp), (val))
/* </private> */
CAMLxparamN (x, (size))
-#if defined (__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7))
+#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7))
#define CAMLunused __attribute__ ((unused))
#else
#define CAMLunused
/* */
/***********************************************************************/
-/* $Id: meta.c 12253 2012-03-21 14:31:18Z xleroy $ */
-
/* Primitives for the toplevel */
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: minor_gc.c 12194 2012-03-06 19:17:29Z doligez $ */
-
#include <string.h>
#include "config.h"
#include "fail.h"
tbl->limit = tbl->threshold;
}
+/* size in bytes */
void caml_set_minor_heap_size (asize_t size)
{
char *new_heap;
void *new_heap_base;
- Assert (size >= Minor_heap_min);
- Assert (size <= Minor_heap_max);
+ Assert (size >= Bsize_wsize(Minor_heap_min));
+ Assert (size <= Bsize_wsize(Minor_heap_max));
Assert (size % sizeof (value) == 0);
if (caml_young_ptr != caml_young_end) caml_minor_collection ();
Assert (caml_young_ptr == caml_young_end);
/* */
/***********************************************************************/
-/* $Id: minor_gc.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_MINOR_GC_H
#define CAML_MINOR_GC_H
(Assert (Is_block (val)), \
(addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
-extern void caml_set_minor_heap_size (asize_t);
+extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
extern void caml_empty_minor_heap (void);
CAMLextern void caml_minor_collection (void);
CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */
/* */
/***********************************************************************/
-/* $Id: misc.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include "config.h"
#include "misc.h"
/* */
/***********************************************************************/
-/* $Id: misc.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Miscellaneous macros and variables. */
#ifndef CAML_MISC_H
#define CAMLprim
#define CAMLextern extern
+/* Weak function definitions that can be overriden by external libs */
+/* Conservatively restricted to ELF and MacOSX platforms */
+#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__))
+#define CAMLweakdef __attribute__((weak))
+#else
+#define CAMLweakdef
+#endif
+
/* Assertions */
/* <private> */
#ifdef DEBUG
-#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
+#define CAMLassert(x) \
+ ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
CAMLextern int caml_failed_assert (char *, char *, int);
#else
#define CAMLassert(x) ((void) 0)
/* */
/***********************************************************************/
-/* $Id: mlvalues.h 12000 2012-01-07 20:55:28Z lefessan $ */
-
#ifndef CAML_MLVALUES_H
#define CAML_MLVALUES_H
/* */
/***********************************************************************/
-/* $Id: obj.c 12149 2012-02-10 16:15:24Z doligez $ */
-
/* Operations on objects */
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: osdeps.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Operating system - specific stuff */
#ifndef CAML_OSDEPS_H
/* */
/***********************************************************************/
-/* $Id: parsing.c 11927 2011-12-21 16:31:01Z xleroy $ */
-
/* The PDA automaton for parsers generated by camlyacc */
#include <stdio.h>
/* */
/***********************************************************************/
-/* $Id: prims.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Interface with C primitives. */
#ifndef CAML_PRIMS_H
/* */
/***********************************************************************/
-/* $Id: printexc.c 11927 2011-12-21 16:31:01Z xleroy $ */
-
/* Print an uncaught exception and abort */
#include <stdio.h>
/* */
/***********************************************************************/
-/* $Id: printexc.h 12000 2012-01-07 20:55:28Z lefessan $ */
-
#ifndef CAML_PRINTEXC_H
#define CAML_PRINTEXC_H
/* */
/***********************************************************************/
-/* $Id: reverse.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Swap byte-order in 16, 32, and 64-bit integers or floats */
#ifndef CAML_REVERSE_H
/* */
/***********************************************************************/
-/* $Id: roots.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* To walk the memory roots for garbage collection */
#include "finalise.h"
/* */
/***********************************************************************/
-/* $Id: roots.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_ROOTS_H
#define CAML_ROOTS_H
/* */
/***********************************************************************/
-/* $Id: signals.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Signal handling, code common to the bytecode and native systems */
#include <signal.h>
+#include <errno.h>
#include "alloc.h"
#include "callback.h"
#include "config.h"
CAMLexport void caml_leave_blocking_section(void)
{
+ int saved_errno;
+ /* Save the value of errno (PR#5982). */
+ saved_errno = errno;
caml_leave_blocking_section_hook ();
caml_process_pending_signals();
+ errno = saved_errno;
}
/* Execute a signal handler immediately */
/* */
/***********************************************************************/
-/* $Id: signals.h 12000 2012-01-07 20:55:28Z lefessan $ */
-
#ifndef CAML_SIGNALS_H
#define CAML_SIGNALS_H
/* */
/***********************************************************************/
-/* $Id: signals_byt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Signal handling, code specific to the bytecode interpreter */
#include <signal.h>
+#include <errno.h>
#include "config.h"
#include "memory.h"
#include "osdeps.h"
static void handle_signal(int signal_number)
{
+ int saved_errno;
+ /* Save the value of errno (PR#5982). */
+ saved_errno = errno;
#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
signal(signal_number, handle_signal);
#endif
caml_enter_blocking_section_hook();
}else{
caml_record_signal(signal_number);
- }
+ }
+ errno = saved_errno;
}
int caml_set_signal_action(int signo, int action)
/* */
/***********************************************************************/
-/* $Id: signals_machdep.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Processor-specific operation: atomic "read and clear" */
#ifndef CAML_SIGNALS_MACHDEP_H
/* */
/***********************************************************************/
-/* $Id: stacks.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* To initialize and resize the stacks */
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: stacks.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* structure of the stacks */
#ifndef CAML_STACKS_H
/* */
/***********************************************************************/
-/* $Id: startup.c 12715 2012-07-16 10:37:03Z frisch $ */
-
/* Start-up code */
#include <stdio.h>
for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white);
if (caml_page_table_add(In_static_data,
caml_atom_table, caml_atom_table + 256) != 0) {
- caml_fatal_error("Fatal error: not enough memory for the initial page table");
+ caml_fatal_error("Fatal error: not enough memory for initial page table");
}
}
static int read_trailer(int fd, struct exec_trailer *trail)
{
- lseek(fd, (long) -TRAILER_SIZE, SEEK_END);
+ if (lseek(fd, (long) -TRAILER_SIZE, SEEK_END) == -1)
+ return BAD_BYTECODE;
if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE)
return BAD_BYTECODE;
fixup_endianness_trailer(&trail->num_sections);
if (opt != NULL){
while (*opt != '\0'){
switch (*opt++){
- case 's': scanmult (opt, &minor_heap_init); break;
- case 'i': scanmult (opt, &heap_chunk_init); break;
+ case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
+ case 'b': caml_record_backtrace(Val_true); break;
case 'h': scanmult (opt, &heap_size_init); break;
+ case 'i': scanmult (opt, &heap_chunk_init); break;
case 'l': scanmult (opt, &max_stack_init); break;
case 'o': scanmult (opt, &percent_free_init); break;
case 'O': scanmult (opt, &max_percent_free_init); break;
- case 'v': scanmult (opt, &caml_verb_gc); break;
- case 'b': caml_record_backtrace(Val_true); break;
case 'p': caml_parser_trace = 1; break;
- case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
+ /* case 'R': see stdlib/hashtbl.mli */
+ case 's': scanmult (opt, &minor_heap_init); break;
+#ifdef DEBUG
+ case 't': caml_trace_flag = 1; break;
+#endif
+ case 'v': scanmult (opt, &caml_verb_gc); break;
}
}
}
extern void caml_signal_thread(void * lpParam);
#endif
+#ifdef _MSC_VER
+
+/* PR 4887: avoid crash box of windows runtime on some system calls */
+extern void caml_install_invalid_parameter_handler();
+
+#endif
+
/* Main entry point when loading code from a file */
CAMLexport void caml_main(char **argv)
/* Machine-dependent initialization of the floating-point hardware
so that it behaves as much as possible as specified in IEEE */
caml_init_ieee_floats();
+#ifdef _MSC_VER
+ caml_install_invalid_parameter_handler();
+#endif
caml_init_custom_operations();
caml_ext_table_init(&caml_shared_libs_path, 8);
caml_external_raise = NULL;
#endif
caml_init_ieee_floats();
+#ifdef _MSC_VER
+ caml_install_invalid_parameter_handler();
+#endif
caml_init_custom_operations();
#ifdef DEBUG
caml_verb_gc = 63;
/* */
/***********************************************************************/
-/* $Id: startup.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_STARTUP_H
#define CAML_STARTUP_H
/* */
/***********************************************************************/
-/* $Id: str.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Operations on strings */
#include <string.h>
return Val_unit;
}
+CAMLprim value caml_string_get16(value str, value index)
+{
+ intnat res;
+ unsigned char b1, b2;
+ intnat idx = Long_val(index);
+ if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error();
+ b1 = Byte_u(str, idx);
+ b2 = Byte_u(str, idx + 1);
+#ifdef ARCH_BIG_ENDIAN
+ res = b1 << 8 | b2;
+#else
+ res = b2 << 8 | b1;
+#endif
+ return Val_int(res);
+}
+
+CAMLprim value caml_string_get32(value str, value index)
+{
+ intnat res;
+ unsigned char b1, b2, b3, b4;
+ intnat idx = Long_val(index);
+ if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error();
+ b1 = Byte_u(str, idx);
+ b2 = Byte_u(str, idx + 1);
+ b3 = Byte_u(str, idx + 2);
+ b4 = Byte_u(str, idx + 3);
+#ifdef ARCH_BIG_ENDIAN
+ res = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+#else
+ res = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+ return caml_copy_int32(res);
+}
+
+#ifdef ARCH_INT64_TYPE
+#include "int64_native.h"
+#else
+#include "int64_emul.h"
+#endif
+
+CAMLprim value caml_string_get64(value str, value index)
+{
+ uint32 reshi;
+ uint32 reslo;
+ unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+ intnat idx = Long_val(index);
+ if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error();
+ b1 = Byte_u(str, idx);
+ b2 = Byte_u(str, idx + 1);
+ b3 = Byte_u(str, idx + 2);
+ b4 = Byte_u(str, idx + 3);
+ b5 = Byte_u(str, idx + 4);
+ b6 = Byte_u(str, idx + 5);
+ b7 = Byte_u(str, idx + 6);
+ b8 = Byte_u(str, idx + 7);
+#ifdef ARCH_BIG_ENDIAN
+ reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+ reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8;
+#else
+ reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5;
+ reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+ return caml_copy_int64(I64_literal(reshi,reslo));
+}
+
+CAMLprim value caml_string_set16(value str, value index, value newval)
+{
+ unsigned char b1, b2;
+ intnat val;
+ intnat idx = Long_val(index);
+ if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error();
+ val = Long_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 8;
+ b2 = 0xFF & val;
+#else
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ Byte_u(str, idx) = b1;
+ Byte_u(str, idx + 1) = b2;
+ return Val_unit;
+}
+
+CAMLprim value caml_string_set32(value str, value index, value newval)
+{
+ unsigned char b1, b2, b3, b4;
+ intnat val;
+ intnat idx = Long_val(index);
+ if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error();
+ val = Int32_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 24;
+ b2 = 0xFF & val >> 16;
+ b3 = 0xFF & val >> 8;
+ b4 = 0xFF & val;
+#else
+ b4 = 0xFF & val >> 24;
+ b3 = 0xFF & val >> 16;
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ Byte_u(str, idx) = b1;
+ Byte_u(str, idx + 1) = b2;
+ Byte_u(str, idx + 2) = b3;
+ Byte_u(str, idx + 3) = b4;
+ return Val_unit;
+}
+
+CAMLprim value caml_string_set64(value str, value index, value newval)
+{
+ unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+ uint32 lo,hi;
+ int64 val;
+ intnat idx = Long_val(index);
+ if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error();
+ val = Int64_val(newval);
+ I64_split(val,hi,lo);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & hi >> 24;
+ b2 = 0xFF & hi >> 16;
+ b3 = 0xFF & hi >> 8;
+ b4 = 0xFF & hi;
+ b5 = 0xFF & lo >> 24;
+ b6 = 0xFF & lo >> 16;
+ b7 = 0xFF & lo >> 8;
+ b8 = 0xFF & lo;
+#else
+ b8 = 0xFF & hi >> 24;
+ b7 = 0xFF & hi >> 16;
+ b6 = 0xFF & hi >> 8;
+ b5 = 0xFF & hi;
+ b4 = 0xFF & lo >> 24;
+ b3 = 0xFF & lo >> 16;
+ b2 = 0xFF & lo >> 8;
+ b1 = 0xFF & lo;
+#endif
+ Byte_u(str, idx) = b1;
+ Byte_u(str, idx + 1) = b2;
+ Byte_u(str, idx + 2) = b3;
+ Byte_u(str, idx + 3) = b4;
+ Byte_u(str, idx + 4) = b5;
+ Byte_u(str, idx + 5) = b6;
+ Byte_u(str, idx + 6) = b7;
+ Byte_u(str, idx + 7) = b8;
+ return Val_unit;
+}
+
CAMLprim value caml_string_equal(value s1, value s2)
{
mlsize_t sz1, sz2;
/* */
/***********************************************************************/
-/* $Id: sys.c 12242 2012-03-14 15:27:58Z xleroy $ */
-
/* Basic system calls */
#include <errno.h>
return res;
}
+CAMLprim value caml_sys_const_big_endian(value unit)
+{
+#ifdef ARCH_BIG_ENDIAN
+ return Val_true;
+#else
+ return Val_false;
+#endif
+}
+
+CAMLprim value caml_sys_const_word_size(value unit)
+{
+ return Val_long(8 * sizeof(value));
+}
+
+CAMLprim value caml_sys_const_ostype_unix(value unit)
+{
+ return Val_long(0 == strcmp(OCAML_OS_TYPE,"Unix"));
+}
+
+CAMLprim value caml_sys_const_ostype_win32(value unit)
+{
+ return Val_long(0 == strcmp(OCAML_OS_TYPE,"Win32"));
+}
+
+CAMLprim value caml_sys_const_ostype_cygwin(value unit)
+{
+ return Val_long(0 == strcmp(OCAML_OS_TYPE,"Cygwin"));
+}
+
CAMLprim value caml_sys_get_config(value unit)
{
CAMLparam0 (); /* unit is unused */
/* */
/***********************************************************************/
-/* $Id: sys.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef CAML_SYS_H
#define CAML_SYS_H
/* */
/***********************************************************************/
-/* $Id: terminfo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Read and output terminal commands */
#include "config.h"
/* */
/***********************************************************************/
-/* $Id: ui.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Function declarations for non-Unix user interfaces */
#ifndef CAML_UI_H
/* */
/***********************************************************************/
-/* $Id: unix.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Unix-specific stuff */
#define _GNU_SOURCE
void * caml_dlopen(char * libname, int for_execution, int global)
{
- return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : RTLD_LOCAL) | RTLD_NODELETE);
+ return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : RTLD_LOCAL)
+ | RTLD_NODELETE);
/* Could use RTLD_LAZY if for_execution == 0, but needs testing */
}
/* */
/***********************************************************************/
-/* $Id: weak.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Operations on weak arrays */
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: weak.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Operations on weak arrays */
#ifndef CAML_WEAK_H
/* */
/***********************************************************************/
-/* $Id: win32.c 12686 2012-07-10 11:34:39Z scherer $ */
-
/* Win32-specific stuff */
#include <windows.h>
#include "signals.h"
#include "sys.h"
-#include "flexdll.h"
+#include <flexdll.h>
#ifndef S_ISREG
#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
pathlen = strlen(name) + 1;
if (pathlen < 256) pathlen = 256;
while (1) {
- fullname = stat_alloc(pathlen);
+ fullname = caml_stat_alloc(pathlen);
retcode = SearchPath(NULL, /* use system search path */
name,
".exe", /* add .exe extension if needed */
break;
}
if (retcode < pathlen) break;
- stat_free(fullname);
+ caml_stat_free(fullname);
pathlen = retcode + 1;
}
return fullname;
{
/* For better randomness, consider:
http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp
+ http://blogs.msdn.com/b/michael_howard/archive/2005/01/14/353379.aspx
*/
FILETIME t;
+ LARGE_INTEGER pc;
GetSystemTimeAsFileTime(&t);
+ QueryPerformanceCounter(&pc); /* PR#6032 */
data[0] = t.dwLowDateTime;
data[1] = t.dwHighDateTime;
data[2] = GetCurrentProcessId();
- return 3;
+ data[3] = pc.LowPart;
+ data[4] = pc.HighPart;
+ return 5;
+}
+
+
+#ifdef _MSC_VER
+
+static void invalid_parameter_handler(const wchar_t* expression,
+ const wchar_t* function,
+ const wchar_t* file,
+ unsigned int line,
+ uintptr_t pReserved)
+{
+ /* no crash box */
}
+
+
+void caml_install_invalid_parameter_handler()
+{
+ _set_invalid_parameter_handler(invalid_parameter_handler);
+}
+
+#endif
fun
[ <:ctyp< $t1$ == $t2$ >> ->
type_decl tl cl loc (Some (ctyp t1)) pflag t2
- | <:ctyp< private $t$ >> ->
- type_decl tl cl loc m True t
+ | <:ctyp@_loc< private $t$ >> ->
+ if pflag then
+ error _loc "multiple private keyword used, use only one instead"
+ else
+ type_decl tl cl loc m True t
| <:ctyp< { $t$ } >> ->
mktype loc tl cl
(Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m
let e2 = ExSeq loc el in
mkexp loc (Pexp_while (expr e1) (expr e2))
| <:expr@loc< let open $i$ in $e$ >> ->
- mkexp loc (Pexp_open (long_uident i) (expr e))
+ mkexp loc (Pexp_open Fresh (long_uident i) (expr e))
| <:expr@loc< (module $me$ : $pt$) >> ->
mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)),
Some (mktyp loc (Ptyp_package (package_type pt))), None))
in
[mksig loc (Psig_modtype (with_loc n loc) si) :: l]
| SgOpn loc id ->
- [mksig loc (Psig_open (long_uident id)) :: l]
+ [mksig loc (Psig_open Fresh (long_uident id)) :: l]
| SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l]
| SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l]
| <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ]
[mkstr loc (Pstr_exception (with_loc (conv_con s) loc)
(List.map ctyp (list_of_ctyp t []))) :: l ]
| <:str_item@loc< exception $uid:s$ = $i$ >> ->
- [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (ident i)) :: l ]
+ [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (long_uident ~conv_con i)) :: l ]
| <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> ->
error loc "type in exception alias"
| StExc _ _ _ -> assert False (*FIXME*)
[mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l]
| StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l]
| StOpn loc id ->
- [mkstr loc (Pstr_open (long_uident id)) :: l]
+ [mkstr loc (Pstr_open Fresh (long_uident id)) :: l]
| StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l]
| StVal loc rf bi ->
[mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l]
* - Nicolas Pouillard: refactoring
*)
+exception Rule_not_found of (string * string);
+
+let () =
+ Printexc.register_printer
+ (fun
+ [ Rule_not_found (symbols, entry) ->
+ let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in
+ Some msg
+ | _ -> None ]) in ()
+;
+
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Parser = Parser.Make Structure;
+ module Print = Print.Make Structure;
open Structure;
+value raise_rule_not_found entry symbols =
+ let to_string f x =
+ let buff = Buffer.create 128 in
+ let ppf = Format.formatter_of_buffer buff in
+ do {
+ f ppf x;
+ Format.pp_print_flush ppf ();
+ Buffer.contents buff
+ } in
+ let entry = to_string Print.entry entry in
+ let symbols = to_string Print.print_rule symbols in
+ raise (Rule_not_found (symbols, entry))
+;
+
(* Deleting a rule *)
(* [delete_rule_in_tree] returns
| None ->
let levs = delete_rule_in_suffix entry symbols levs in
[lev :: levs] ]
- | [] -> raise Not_found ]
+ | [] -> raise_rule_not_found entry symbols ]
;
value rec delete_rule_in_prefix entry symbols =
| None ->
let levs = delete_rule_in_prefix entry symbols levs in
[lev :: levs] ]
- | [] -> raise Not_found ]
+ | [] -> raise_rule_not_found entry symbols ]
;
value rec delete_rule_in_level_list entry symbols levs =
try do {
DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END;
True
- } with [ Not_found -> False ];
+ } with [ Struct.Grammar.Delete.Rule_not_found _ -> False ];
value comprehension_or_sem_expr_for_list =
Gram.Entry.mk "comprehension_or_sem_expr_for_list";
clear package_type;
clear top_phrase;
- EXTEND Gram
+ let apply () = EXTEND Gram
GLOBAL:
a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT
a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident
| `EOI -> None
] ]
;
- END;
+ END in apply ();
(* Some other DELETE_RULE are before the grammar *)
DELETE_RULE Gram module_longident_with_app: "("; SELF; ")" END;
value revised =
try
(DELETE_RULE Gram expr: "if"; SELF; "then"; SELF; "else"; SELF END; True)
- with [ Not_found -> begin
+ with [ Struct.Grammar.Delete.Rule_not_found _ -> begin
DELETE_RULE Gram expr: "if"; SELF; "then"; expr LEVEL "top"; "else"; expr LEVEL "top" END;
DELETE_RULE Gram expr: "if"; SELF; "then"; expr LEVEL "top" END; False
end ];
parser [: a = symb; s :] -> kont a s
end;
- EXTEND Gram
+ let apply () = EXTEND Gram
GLOBAL:
a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT rec_binding_quot
a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident
expr_eoi:
[ [ x = expr; `EOI -> x ] ]
;
- END;
+ END in apply ();
end;
function
| Ast.TyMan (_, t1, t2) ->
type_decl tl cl loc (Some (ctyp t1)) pflag t2
- | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t
+ | Ast.TyPrv (_loc, t) ->
+ if pflag
+ then
+ error _loc
+ "multiple private keyword used, use only one instead"
+ else type_decl tl cl loc m true t
| Ast.TyRec (_, t) ->
mktype loc tl cl
(Ptype_record (List.map mktrecord (list_of_ctyp t [])))
let e2 = ExSeq (loc, el)
in mkexp loc (Pexp_while ((expr e1), (expr e2)))
| Ast.ExOpI (loc, i, e) ->
- mkexp loc (Pexp_open ((long_uident i), (expr e)))
+ mkexp loc (Pexp_open (Fresh, (long_uident i), (expr e)))
| Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) ->
mkexp loc
(Pexp_constraint
| _ -> Pmodtype_manifest (module_type mt))
in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l
| SgOpn (loc, id) ->
- (mksig loc (Psig_open (long_uident id))) :: l
+ (mksig loc (Psig_open (Fresh, (long_uident id)))) :: l
| SgTyp (loc, tdl) ->
(mksig loc (Psig_type (mktype_decl tdl []))) :: l
| SgVal (loc, n, t) ->
(Ast.OSome i)) ->
(mkstr loc
(Pstr_exn_rebind ((with_loc (conv_con s) loc),
- (ident i)))) ::
+ (long_uident ~conv_con i)))) ::
l
| Ast.StExc (loc,
(Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)),
(Pstr_modtype ((with_loc n loc), (module_type mt)))) ::
l
| StOpn (loc, id) ->
- (mkstr loc (Pstr_open (long_uident id))) :: l
+ (mkstr loc (Pstr_open (Fresh, (long_uident id)))) :: l
| StTyp (loc, tdl) ->
(mkstr loc (Pstr_type (mktype_decl tdl []))) :: l
| StVal (loc, rf, bi) ->
module Delete =
struct
+ exception Rule_not_found of (string * string)
+
+ let _ =
+ let () =
+ Printexc.register_printer
+ (function
+ | Rule_not_found ((symbols, entry)) ->
+ let msg =
+ Printf.sprintf
+ "rule %S cannot be found in entry\n%s" symbols
+ entry
+ in Some msg
+ | _ -> None)
+ in ()
+
module Make (Structure : Structure.S) =
struct
module Tools = Tools.Make(Structure)
module Parser = Parser.Make(Structure)
+ module Print = Print.Make(Structure)
+
open Structure
+ let raise_rule_not_found entry symbols =
+ let to_string f x =
+ let buff = Buffer.create 128 in
+ let ppf = Format.formatter_of_buffer buff
+ in
+ (f ppf x;
+ Format.pp_print_flush ppf ();
+ Buffer.contents buff) in
+ let entry = to_string Print.entry entry in
+ let symbols = to_string Print.print_rule symbols
+ in raise (Rule_not_found ((symbols, entry)))
+
let delete_rule_in_tree entry =
let rec delete_in_tree symbols tree =
match (symbols, tree) with
let levs =
delete_rule_in_suffix entry symbols levs
in lev :: levs)
- | [] -> raise Not_found
+ | [] -> raise_rule_not_found entry symbols
let rec delete_rule_in_prefix entry symbols =
function
let levs =
delete_rule_in_prefix entry symbols levs
in lev :: levs)
- | [] -> raise Not_found
+ | [] -> raise_rule_not_found entry symbols
let rec delete_rule_in_level_list entry symbols levs =
match symbols with
let a = symb __strm in kont a __strm)
let _ =
- let _ = (a_CHAR : 'a_CHAR Gram.Entry.t)
- and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t)
- and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t)
- and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t)
- and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t)
- and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t)
- and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t)
- and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t)
- and _ = (package_type : 'package_type Gram.Entry.t)
- and _ = (do_sequence : 'do_sequence Gram.Entry.t)
- and _ = (infixop4 : 'infixop4 Gram.Entry.t)
- and _ = (infixop3 : 'infixop3 Gram.Entry.t)
- and _ = (infixop2 : 'infixop2 Gram.Entry.t)
- and _ = (infixop1 : 'infixop1 Gram.Entry.t)
- and _ = (infixop0 : 'infixop0 Gram.Entry.t)
- and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t)
- and _ = (with_constr : 'with_constr Gram.Entry.t)
- and _ = (value_val : 'value_val Gram.Entry.t)
- and _ = (value_let : 'value_let Gram.Entry.t)
- and _ = (val_longident : 'val_longident Gram.Entry.t)
- and _ = (use_file : 'use_file Gram.Entry.t)
- and _ = (typevars : 'typevars Gram.Entry.t)
- and _ = (type_parameters : 'type_parameters Gram.Entry.t)
- and _ = (type_parameter : 'type_parameter Gram.Entry.t)
- and _ =
- (type_longident_and_parameters :
- 'type_longident_and_parameters Gram.Entry.t)
- and _ = (type_longident : 'type_longident Gram.Entry.t)
- and _ = (type_kind : 'type_kind Gram.Entry.t)
- and _ =
- (type_ident_and_parameters :
- 'type_ident_and_parameters Gram.Entry.t)
- and _ = (type_declaration : 'type_declaration Gram.Entry.t)
- and _ = (type_constraint : 'type_constraint Gram.Entry.t)
- and _ = (top_phrase : 'top_phrase Gram.Entry.t)
- and _ = (str_items : 'str_items Gram.Entry.t)
- and _ = (str_item_quot : 'str_item_quot Gram.Entry.t)
- and _ = (str_item : 'str_item Gram.Entry.t)
- and _ = (star_ctyp : 'star_ctyp Gram.Entry.t)
- and _ = (sig_items : 'sig_items Gram.Entry.t)
- and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t)
- and _ = (sig_item : 'sig_item Gram.Entry.t)
- and _ = (sequence : 'sequence Gram.Entry.t)
- and _ = (semi : 'semi Gram.Entry.t)
- and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t)
- and _ = (sem_patt : 'sem_patt Gram.Entry.t)
- and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)
- and _ = (sem_expr : 'sem_expr Gram.Entry.t)
- and _ = (row_field : 'row_field Gram.Entry.t)
- and _ = (poly_type : 'poly_type Gram.Entry.t)
- and _ = (phrase : 'phrase Gram.Entry.t)
- and _ = (patt_tcon : 'patt_tcon Gram.Entry.t)
- and _ = (patt_quot : 'patt_quot Gram.Entry.t)
- and _ = (patt_eoi : 'patt_eoi Gram.Entry.t)
- and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t)
- and _ = (patt : 'patt Gram.Entry.t)
- and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t)
- and _ = (opt_virtual : 'opt_virtual Gram.Entry.t)
- and _ = (opt_rec : 'opt_rec Gram.Entry.t)
- and _ = (opt_private : 'opt_private Gram.Entry.t)
- and _ = (opt_polyt : 'opt_polyt Gram.Entry.t)
- and _ = (opt_mutable : 'opt_mutable Gram.Entry.t)
- and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t)
- and _ = (opt_expr : 'opt_expr Gram.Entry.t)
- and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)
- and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)
- and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t)
- and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t)
- and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t)
- and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t)
- and _ = (name_tags : 'name_tags Gram.Entry.t)
- and _ = (more_ctyp : 'more_ctyp Gram.Entry.t)
- and _ = (module_type_quot : 'module_type_quot Gram.Entry.t)
- and _ = (module_type : 'module_type Gram.Entry.t)
- and _ =
- (module_rec_declaration : 'module_rec_declaration Gram.Entry.t)
- and _ =
- (module_longident_with_app :
- 'module_longident_with_app Gram.Entry.t)
- and _ = (module_longident : 'module_longident Gram.Entry.t)
- and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t)
- and _ = (module_expr : 'module_expr Gram.Entry.t)
- and _ = (module_declaration : 'module_declaration Gram.Entry.t)
- and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t)
- and _ = (module_binding0 : 'module_binding0 Gram.Entry.t)
- and _ = (module_binding : 'module_binding Gram.Entry.t)
- and _ = (meth_decl : 'meth_decl Gram.Entry.t)
- and _ = (meth_list : 'meth_list Gram.Entry.t)
- and _ = (let_binding : 'let_binding Gram.Entry.t)
- and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)
- and _ = (label_patt_list : 'label_patt_list Gram.Entry.t)
- and _ = (label_patt : 'label_patt Gram.Entry.t)
- and _ = (label_longident : 'label_longident Gram.Entry.t)
- and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t)
- and _ = (label_ipatt : 'label_ipatt Gram.Entry.t)
- and _ = (label_expr_list : 'label_expr_list Gram.Entry.t)
- and _ = (label_expr : 'label_expr Gram.Entry.t)
- and _ =
- (label_declaration_list : 'label_declaration_list Gram.Entry.t)
- and _ = (label_declaration : 'label_declaration Gram.Entry.t)
- and _ = (label : 'label Gram.Entry.t)
- and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)
- and _ = (ipatt : 'ipatt Gram.Entry.t)
- and _ = (interf : 'interf Gram.Entry.t)
- and _ = (implem : 'implem Gram.Entry.t)
- and _ = (ident_quot : 'ident_quot Gram.Entry.t)
- and _ = (ident : 'ident Gram.Entry.t)
- and _ = (fun_def : 'fun_def Gram.Entry.t)
- and _ = (fun_binding : 'fun_binding Gram.Entry.t)
- and _ = (field_expr_list : 'field_expr_list Gram.Entry.t)
- and _ = (field_expr : 'field_expr Gram.Entry.t)
- and _ = (expr_quot : 'expr_quot Gram.Entry.t)
- and _ = (expr_eoi : 'expr_eoi Gram.Entry.t)
- and _ = (expr : 'expr Gram.Entry.t)
- and _ = (eq_expr : 'eq_expr Gram.Entry.t)
- and _ = (dummy : 'dummy Gram.Entry.t)
- and _ = (direction_flag : 'direction_flag Gram.Entry.t)
- and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t)
- and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t)
- and _ = (ctyp : 'ctyp Gram.Entry.t)
- and _ =
- (constructor_declarations :
- 'constructor_declarations Gram.Entry.t)
- and _ =
- (constructor_declaration : 'constructor_declaration Gram.Entry.t)
- and _ = (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)
- and _ = (constrain : 'constrain Gram.Entry.t)
- and _ = (comma_type_parameter : 'comma_type_parameter Gram.Entry.t)
- and _ = (comma_patt : 'comma_patt Gram.Entry.t)
- and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t)
- and _ = (comma_expr : 'comma_expr Gram.Entry.t)
- and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t)
- and _ = (class_type_quot : 'class_type_quot Gram.Entry.t)
- and _ = (class_type_plus : 'class_type_plus Gram.Entry.t)
- and _ =
- (class_type_longident_and_param :
- 'class_type_longident_and_param Gram.Entry.t)
- and _ = (class_type_longident : 'class_type_longident Gram.Entry.t)
- and _ =
- (class_type_declaration : 'class_type_declaration Gram.Entry.t)
- and _ = (class_type : 'class_type Gram.Entry.t)
- and _ = (class_structure : 'class_structure Gram.Entry.t)
- and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t)
- and _ = (class_str_item : 'class_str_item Gram.Entry.t)
- and _ = (class_signature : 'class_signature Gram.Entry.t)
- and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t)
- and _ = (class_sig_item : 'class_sig_item Gram.Entry.t)
- and _ = (class_name_and_param : 'class_name_and_param Gram.Entry.t)
- and _ =
- (class_longident_and_param :
- 'class_longident_and_param Gram.Entry.t)
- and _ = (class_longident : 'class_longident Gram.Entry.t)
- and _ =
- (class_info_for_class_type :
- 'class_info_for_class_type Gram.Entry.t)
- and _ =
- (class_info_for_class_expr :
- 'class_info_for_class_expr Gram.Entry.t)
- and _ = (class_fun_def : 'class_fun_def Gram.Entry.t)
- and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t)
- and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t)
- and _ = (class_expr : 'class_expr Gram.Entry.t)
- and _ = (class_description : 'class_description Gram.Entry.t)
- and _ = (class_declaration : 'class_declaration Gram.Entry.t)
- and _ = (binding_quot : 'binding_quot Gram.Entry.t)
- and _ = (binding : 'binding Gram.Entry.t)
- and _ = (match_case_quot : 'match_case_quot Gram.Entry.t)
- and _ = (match_case0 : 'match_case0 Gram.Entry.t)
- and _ = (match_case : 'match_case Gram.Entry.t)
- and _ = (and_ctyp : 'and_ctyp Gram.Entry.t)
- and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t)
- and _ = (a_ident : 'a_ident Gram.Entry.t)
- and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t)
- and _ = (a_STRING : 'a_STRING Gram.Entry.t)
- and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)
- and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)
- and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t)
- and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t)
- and _ = (a_LABEL : 'a_LABEL Gram.Entry.t)
- and _ = (a_INT64 : 'a_INT64 Gram.Entry.t)
- and _ = (a_INT32 : 'a_INT32 Gram.Entry.t)
- and _ = (a_INT : 'a_INT Gram.Entry.t)
- and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in
- let grammar_entry_create = Gram.Entry.mk in
- let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *)
- (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t =
- grammar_entry_create "infixop5"
- and (* | i = opt_label; "("; p = patt_tcon; ")" -> *)
- (* <:patt< ? $i$ : ($p$) >> *)
- (* | i = opt_label; "("; p = ipatt_tcon; ")" ->
+ let apply () =
+ let _ = (a_CHAR : 'a_CHAR Gram.Entry.t)
+ and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t)
+ and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t)
+ and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t)
+ and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t)
+ and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t)
+ and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t)
+ and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t)
+ and _ = (package_type : 'package_type Gram.Entry.t)
+ and _ = (do_sequence : 'do_sequence Gram.Entry.t)
+ and _ = (infixop4 : 'infixop4 Gram.Entry.t)
+ and _ = (infixop3 : 'infixop3 Gram.Entry.t)
+ and _ = (infixop2 : 'infixop2 Gram.Entry.t)
+ and _ = (infixop1 : 'infixop1 Gram.Entry.t)
+ and _ = (infixop0 : 'infixop0 Gram.Entry.t)
+ and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t)
+ and _ = (with_constr : 'with_constr Gram.Entry.t)
+ and _ = (value_val : 'value_val Gram.Entry.t)
+ and _ = (value_let : 'value_let Gram.Entry.t)
+ and _ = (val_longident : 'val_longident Gram.Entry.t)
+ and _ = (use_file : 'use_file Gram.Entry.t)
+ and _ = (typevars : 'typevars Gram.Entry.t)
+ and _ = (type_parameters : 'type_parameters Gram.Entry.t)
+ and _ = (type_parameter : 'type_parameter Gram.Entry.t)
+ and _ =
+ (type_longident_and_parameters :
+ 'type_longident_and_parameters Gram.Entry.t)
+ and _ = (type_longident : 'type_longident Gram.Entry.t)
+ and _ = (type_kind : 'type_kind Gram.Entry.t)
+ and _ =
+ (type_ident_and_parameters :
+ 'type_ident_and_parameters Gram.Entry.t)
+ and _ = (type_declaration : 'type_declaration Gram.Entry.t)
+ and _ = (type_constraint : 'type_constraint Gram.Entry.t)
+ and _ = (top_phrase : 'top_phrase Gram.Entry.t)
+ and _ = (str_items : 'str_items Gram.Entry.t)
+ and _ = (str_item_quot : 'str_item_quot Gram.Entry.t)
+ and _ = (str_item : 'str_item Gram.Entry.t)
+ and _ = (star_ctyp : 'star_ctyp Gram.Entry.t)
+ and _ = (sig_items : 'sig_items Gram.Entry.t)
+ and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t)
+ and _ = (sig_item : 'sig_item Gram.Entry.t)
+ and _ = (sequence : 'sequence Gram.Entry.t)
+ and _ = (semi : 'semi Gram.Entry.t)
+ and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t)
+ and _ = (sem_patt : 'sem_patt Gram.Entry.t)
+ and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)
+ and _ = (sem_expr : 'sem_expr Gram.Entry.t)
+ and _ = (row_field : 'row_field Gram.Entry.t)
+ and _ = (poly_type : 'poly_type Gram.Entry.t)
+ and _ = (phrase : 'phrase Gram.Entry.t)
+ and _ = (patt_tcon : 'patt_tcon Gram.Entry.t)
+ and _ = (patt_quot : 'patt_quot Gram.Entry.t)
+ and _ = (patt_eoi : 'patt_eoi Gram.Entry.t)
+ and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t)
+ and _ = (patt : 'patt Gram.Entry.t)
+ and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t)
+ and _ = (opt_virtual : 'opt_virtual Gram.Entry.t)
+ and _ = (opt_rec : 'opt_rec Gram.Entry.t)
+ and _ = (opt_private : 'opt_private Gram.Entry.t)
+ and _ = (opt_polyt : 'opt_polyt Gram.Entry.t)
+ and _ = (opt_mutable : 'opt_mutable Gram.Entry.t)
+ and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t)
+ and _ = (opt_expr : 'opt_expr Gram.Entry.t)
+ and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)
+ and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)
+ and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t)
+ and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t)
+ and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t)
+ and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t)
+ and _ = (name_tags : 'name_tags Gram.Entry.t)
+ and _ = (more_ctyp : 'more_ctyp Gram.Entry.t)
+ and _ = (module_type_quot : 'module_type_quot Gram.Entry.t)
+ and _ = (module_type : 'module_type Gram.Entry.t)
+ and _ =
+ (module_rec_declaration : 'module_rec_declaration Gram.Entry.t)
+ and _ =
+ (module_longident_with_app :
+ 'module_longident_with_app Gram.Entry.t)
+ and _ = (module_longident : 'module_longident Gram.Entry.t)
+ and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t)
+ and _ = (module_expr : 'module_expr Gram.Entry.t)
+ and _ = (module_declaration : 'module_declaration Gram.Entry.t)
+ and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t)
+ and _ = (module_binding0 : 'module_binding0 Gram.Entry.t)
+ and _ = (module_binding : 'module_binding Gram.Entry.t)
+ and _ = (meth_decl : 'meth_decl Gram.Entry.t)
+ and _ = (meth_list : 'meth_list Gram.Entry.t)
+ and _ = (let_binding : 'let_binding Gram.Entry.t)
+ and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)
+ and _ = (label_patt_list : 'label_patt_list Gram.Entry.t)
+ and _ = (label_patt : 'label_patt Gram.Entry.t)
+ and _ = (label_longident : 'label_longident Gram.Entry.t)
+ and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t)
+ and _ = (label_ipatt : 'label_ipatt Gram.Entry.t)
+ and _ = (label_expr_list : 'label_expr_list Gram.Entry.t)
+ and _ = (label_expr : 'label_expr Gram.Entry.t)
+ and _ =
+ (label_declaration_list : 'label_declaration_list Gram.Entry.t)
+ and _ = (label_declaration : 'label_declaration Gram.Entry.t)
+ and _ = (label : 'label Gram.Entry.t)
+ and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)
+ and _ = (ipatt : 'ipatt Gram.Entry.t)
+ and _ = (interf : 'interf Gram.Entry.t)
+ and _ = (implem : 'implem Gram.Entry.t)
+ and _ = (ident_quot : 'ident_quot Gram.Entry.t)
+ and _ = (ident : 'ident Gram.Entry.t)
+ and _ = (fun_def : 'fun_def Gram.Entry.t)
+ and _ = (fun_binding : 'fun_binding Gram.Entry.t)
+ and _ = (field_expr_list : 'field_expr_list Gram.Entry.t)
+ and _ = (field_expr : 'field_expr Gram.Entry.t)
+ and _ = (expr_quot : 'expr_quot Gram.Entry.t)
+ and _ = (expr_eoi : 'expr_eoi Gram.Entry.t)
+ and _ = (expr : 'expr Gram.Entry.t)
+ and _ = (eq_expr : 'eq_expr Gram.Entry.t)
+ and _ = (dummy : 'dummy Gram.Entry.t)
+ and _ = (direction_flag : 'direction_flag Gram.Entry.t)
+ and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t)
+ and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t)
+ and _ = (ctyp : 'ctyp Gram.Entry.t)
+ and _ =
+ (constructor_declarations :
+ 'constructor_declarations Gram.Entry.t)
+ and _ =
+ (constructor_declaration :
+ 'constructor_declaration Gram.Entry.t)
+ and _ =
+ (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)
+ and _ = (constrain : 'constrain Gram.Entry.t)
+ and _ =
+ (comma_type_parameter : 'comma_type_parameter Gram.Entry.t)
+ and _ = (comma_patt : 'comma_patt Gram.Entry.t)
+ and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t)
+ and _ = (comma_expr : 'comma_expr Gram.Entry.t)
+ and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t)
+ and _ = (class_type_quot : 'class_type_quot Gram.Entry.t)
+ and _ = (class_type_plus : 'class_type_plus Gram.Entry.t)
+ and _ =
+ (class_type_longident_and_param :
+ 'class_type_longident_and_param Gram.Entry.t)
+ and _ =
+ (class_type_longident : 'class_type_longident Gram.Entry.t)
+ and _ =
+ (class_type_declaration : 'class_type_declaration Gram.Entry.t)
+ and _ = (class_type : 'class_type Gram.Entry.t)
+ and _ = (class_structure : 'class_structure Gram.Entry.t)
+ and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t)
+ and _ = (class_str_item : 'class_str_item Gram.Entry.t)
+ and _ = (class_signature : 'class_signature Gram.Entry.t)
+ and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t)
+ and _ = (class_sig_item : 'class_sig_item Gram.Entry.t)
+ and _ =
+ (class_name_and_param : 'class_name_and_param Gram.Entry.t)
+ and _ =
+ (class_longident_and_param :
+ 'class_longident_and_param Gram.Entry.t)
+ and _ = (class_longident : 'class_longident Gram.Entry.t)
+ and _ =
+ (class_info_for_class_type :
+ 'class_info_for_class_type Gram.Entry.t)
+ and _ =
+ (class_info_for_class_expr :
+ 'class_info_for_class_expr Gram.Entry.t)
+ and _ = (class_fun_def : 'class_fun_def Gram.Entry.t)
+ and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t)
+ and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t)
+ and _ = (class_expr : 'class_expr Gram.Entry.t)
+ and _ = (class_description : 'class_description Gram.Entry.t)
+ and _ = (class_declaration : 'class_declaration Gram.Entry.t)
+ and _ = (binding_quot : 'binding_quot Gram.Entry.t)
+ and _ = (binding : 'binding Gram.Entry.t)
+ and _ = (match_case_quot : 'match_case_quot Gram.Entry.t)
+ and _ = (match_case0 : 'match_case0 Gram.Entry.t)
+ and _ = (match_case : 'match_case Gram.Entry.t)
+ and _ = (and_ctyp : 'and_ctyp Gram.Entry.t)
+ and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t)
+ and _ = (a_ident : 'a_ident Gram.Entry.t)
+ and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t)
+ and _ = (a_STRING : 'a_STRING Gram.Entry.t)
+ and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)
+ and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)
+ and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t)
+ and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t)
+ and _ = (a_LABEL : 'a_LABEL Gram.Entry.t)
+ and _ = (a_INT64 : 'a_INT64 Gram.Entry.t)
+ and _ = (a_INT32 : 'a_INT32 Gram.Entry.t)
+ and _ = (a_INT : 'a_INT Gram.Entry.t)
+ and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in
+ let grammar_entry_create = Gram.Entry.mk in
+ let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *)
+ (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t =
+ grammar_entry_create "infixop5"
+ and (* | i = opt_label; "("; p = patt_tcon; ")" -> *)
+ (* <:patt< ? $i$ : ($p$) >> *)
+ (* | i = opt_label; "("; p = ipatt_tcon; ")" ->
<:patt< ? $i$ : ($p$) >>
| i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" ->
<:patt< ? $i$ : ($p$ = $e$) >> *)
- string_list : 'string_list Gram.Entry.t =
- grammar_entry_create "string_list"
- and opt_override : 'opt_override Gram.Entry.t =
- grammar_entry_create "opt_override"
- and unquoted_typevars : 'unquoted_typevars Gram.Entry.t =
- grammar_entry_create "unquoted_typevars"
- and value_val_opt_override : 'value_val_opt_override Gram.Entry.t =
- grammar_entry_create "value_val_opt_override"
- and method_opt_override : 'method_opt_override Gram.Entry.t =
- grammar_entry_create "method_opt_override"
- and module_longident_dot_lparen :
- 'module_longident_dot_lparen Gram.Entry.t =
- grammar_entry_create "module_longident_dot_lparen"
- and optional_type_parameter :
- 'optional_type_parameter Gram.Entry.t =
- grammar_entry_create "optional_type_parameter"
- and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t =
- grammar_entry_create "fun_def_cont_no_when"
- and fun_def_cont : 'fun_def_cont Gram.Entry.t =
- grammar_entry_create "fun_def_cont"
- and sequence' : 'sequence' Gram.Entry.t =
- grammar_entry_create "sequence'"
- and infixop6 : 'infixop6 Gram.Entry.t =
- grammar_entry_create "infixop6"
- in
- (Gram.extend (module_expr : 'module_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "top"), None,
- [ ([ Gram.Skeyword "struct";
- Gram.Snterm
- (Gram.Entry.obj
- (str_items : 'str_items Gram.Entry.t));
- Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t)
- -> (Ast.MeStr (_loc, st) : 'module_expr))));
- ([ Gram.Skeyword "functor"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.Sself ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ _ (t : 'module_type)
- _ (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
- (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]);
- ((Some "apply"), None,
- [ ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (me2 : 'module_expr) (me1 : 'module_expr)
- (_loc : Gram.Loc.t) ->
- (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (package_type : 'package_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'package_type) _ (e : 'expr) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.MePkg (_loc,
- (Ast.ExTyc (_loc, e,
- (Ast.TyPkg (_loc, p))))) :
- 'module_expr))));
- ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) ->
- (Ast.MePkg (_loc, e) : 'module_expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (me : 'module_expr) _ (_loc : Gram.Loc.t)
- -> (me : 'module_expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (mt : 'module_type) _ (me : 'module_expr)
- _ (_loc : Gram.Loc.t) ->
- (Ast.MeTyc (_loc, me, mt) : 'module_expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'module_longident) (_loc : Gram.Loc.t)
- -> (Ast.MeId (_loc, i) : 'module_expr))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.module_expr_tag :
- 'module_expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "mexp" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "mexp" | "anti" | "list" as n)),
- s) ->
- (Ast.MeAnt (_loc,
- (mk_anti ~c: "module_expr" n s)) :
- 'module_expr)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (str_item : 'str_item Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "top"), None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) (_loc : Gram.Loc.t) ->
- (Ast.StExp (_loc, e) : 'str_item))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.str_item_tag :
- 'str_item)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "stri" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "stri" | "anti" | "list" as n)),
- s) ->
- (Ast.StAnt (_loc,
- (mk_anti ~c: "str_item" n s)) :
- 'str_item)
- | _ -> assert false)));
- ([ Gram.Skeyword "class"; Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type_declaration :
- 'class_type_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ctd : 'class_type_declaration) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.StClt (_loc, ctd) : 'str_item))));
- ([ Gram.Skeyword "class";
- Gram.Snterm
- (Gram.Entry.obj
- (class_declaration :
- 'class_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (cd : 'class_declaration) _
- (_loc : Gram.Loc.t) ->
- (Ast.StCls (_loc, cd) : 'str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_let : 'value_let Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (binding : 'binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (bi : 'binding) (r : 'opt_rec) _
- (_loc : Gram.Loc.t) ->
- (Ast.StVal (_loc, r, bi) : 'str_item))));
- ([ Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (type_declaration :
- 'type_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (td : 'type_declaration) _
- (_loc : Gram.Loc.t) ->
- (Ast.StTyp (_loc, td) : 'str_item))));
- ([ Gram.Skeyword "open";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'module_longident) _
- (_loc : Gram.Loc.t) ->
- (Ast.StOpn (_loc, i) : 'str_item))));
- ([ Gram.Skeyword "module"; Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ (i : 'a_ident) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.StMty (_loc, i, mt) : 'str_item))));
- ([ Gram.Skeyword "module"; Gram.Skeyword "rec";
- Gram.Snterm
- (Gram.Entry.obj
- (module_binding :
- 'module_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mb : 'module_binding) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.StRecMod (_loc, mb) : 'str_item))));
- ([ Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (module_binding0 :
- 'module_binding0 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mb : 'module_binding0) (i : 'a_UIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.StMod (_loc, i, mb) : 'str_item))));
- ([ Gram.Skeyword "include";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (_loc : Gram.Loc.t)
- -> (Ast.StInc (_loc, me) : 'str_item))));
- ([ Gram.Skeyword "external";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (string_list : 'string_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (sl : 'string_list) _ (t : 'ctyp) _
- (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.StExt (_loc, i, t, sl) : 'str_item))));
- ([ Gram.Skeyword "exception";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (type_longident :
- 'type_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'type_longident) _
- (t : 'constructor_declaration) _
- (_loc : Gram.Loc.t) ->
- (Ast.StExc (_loc, t, (Ast.OSome i)) :
- 'str_item))));
- ([ Gram.Skeyword "exception";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'constructor_declaration) _
- (_loc : Gram.Loc.t) ->
- (Ast.StExc (_loc, t, Ast.ONone) : 'str_item)))) ]) ]))
- ());
- Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (_loc : Gram.Loc.t)
- -> (me : 'module_binding0))));
- ([ Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (mt : 'module_type) _
- (_loc : Gram.Loc.t) ->
- (Ast.MeTyc (_loc, me, mt) : 'module_binding0))));
- ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword ")"; Gram.Sself ],
- (Gram.Action.mk
- (fun (mb : 'module_binding0) _
- (mt : 'module_type) _ (m : 'a_UIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.MeFun (_loc, m, mt, mb) :
- 'module_binding0)))) ]) ]))
- ());
- Gram.extend (module_binding : 'module_binding Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (mt : 'module_type) _
- (m : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.MbColEq (_loc, m, mt, me) :
- 'module_binding))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.module_binding_tag :
- 'module_binding)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)"));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (mt : 'module_type) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), m) ->
- (Ast.MbColEq (_loc, (mk_anti n m), mt,
- me) :
- 'module_binding)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), s) ->
- (Ast.MbAnt (_loc,
- (mk_anti ~c: "module_binding" n s)) :
- 'module_binding)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT
- (("module_binding" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("module_binding" | "anti" | "list" as
- n)),
- s) ->
- (Ast.MbAnt (_loc,
- (mk_anti ~c: "module_binding" n s)) :
- 'module_binding)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (b2 : 'module_binding) _
- (b1 : 'module_binding) (_loc : Gram.Loc.t) ->
- (Ast.MbAnd (_loc, b1, b2) : 'module_binding)))) ]) ]))
- ());
- Gram.extend (module_type : 'module_type Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "top"), None,
- [ ([ Gram.Skeyword "functor"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":"; Gram.Sself; Gram.Skeyword ")";
- Gram.Skeyword "->"; Gram.Sself ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ _ (t : 'module_type)
- _ (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
- (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]);
- ((Some "with"), None,
- [ ([ Gram.Sself; Gram.Skeyword "with";
- Gram.Snterm
- (Gram.Entry.obj
- (with_constr : 'with_constr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (wc : 'with_constr) _ (mt : 'module_type)
- (_loc : Gram.Loc.t) ->
- (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]);
- ((Some "apply"), None,
- [ ([ Gram.Sself; Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (mt2 : 'module_type) (mt1 : 'module_type)
- (_loc : Gram.Loc.t) ->
- (module_type_app mt1 mt2 : 'module_type)))) ]);
- ((Some "."), None,
- [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (mt2 : 'module_type) _ (mt1 : 'module_type)
- (_loc : Gram.Loc.t) ->
- (module_type_acc mt1 mt2 : 'module_type)))) ]);
- ((Some "sig"), None,
- [ ([ Gram.Skeyword "sig";
- Gram.Snterm
- (Gram.Entry.obj
- (sig_items : 'sig_items Gram.Entry.t));
- Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t)
- -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "module"; Gram.Skeyword "type";
- Gram.Skeyword "of";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ _ _
- (_loc : Gram.Loc.t) ->
- (Ast.MtOf (_loc, me) : 'module_type))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (mt : 'module_type) _ (_loc : Gram.Loc.t)
- -> (mt : 'module_type))));
- ([ Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.MtQuo (_loc, i) : 'module_type))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (module_longident_with_app :
- 'module_longident_with_app Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'module_longident_with_app)
- (_loc : Gram.Loc.t) ->
- (Ast.MtId (_loc, i) : 'module_type))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.module_type_tag :
- 'module_type)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "mtyp" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "mtyp" | "anti" | "list" as n)),
- s) ->
- (Ast.MtAnt (_loc,
- (mk_anti ~c: "module_type" n s)) :
- 'module_type)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (sig_item : 'sig_item Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "top"), None,
- [ ([ Gram.Skeyword "class"; Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type_declaration :
- 'class_type_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ctd : 'class_type_declaration) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.SgClt (_loc, ctd) : 'sig_item))));
- ([ Gram.Skeyword "class";
- Gram.Snterm
- (Gram.Entry.obj
- (class_description :
- 'class_description Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (cd : 'class_description) _
- (_loc : Gram.Loc.t) ->
- (Ast.SgCls (_loc, cd) : 'sig_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (i : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.SgVal (_loc, i, t) : 'sig_item))));
- ([ Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (type_declaration :
- 'type_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'type_declaration) _
- (_loc : Gram.Loc.t) ->
- (Ast.SgTyp (_loc, t) : 'sig_item))));
- ([ Gram.Skeyword "open";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'module_longident) _
- (_loc : Gram.Loc.t) ->
- (Ast.SgOpn (_loc, i) : 'sig_item))));
- ([ Gram.Skeyword "module"; Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
- (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) :
- 'sig_item))));
- ([ Gram.Skeyword "module"; Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ (i : 'a_ident) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.SgMty (_loc, i, mt) : 'sig_item))));
- ([ Gram.Skeyword "module"; Gram.Skeyword "rec";
- Gram.Snterm
- (Gram.Entry.obj
- (module_rec_declaration :
- 'module_rec_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mb : 'module_rec_declaration) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.SgRecMod (_loc, mb) : 'sig_item))));
- ([ Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (module_declaration :
- 'module_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_declaration) (i : 'a_UIDENT)
- _ (_loc : Gram.Loc.t) ->
- (Ast.SgMod (_loc, i, mt) : 'sig_item))));
- ([ Gram.Skeyword "include";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ (_loc : Gram.Loc.t)
- -> (Ast.SgInc (_loc, mt) : 'sig_item))));
- ([ Gram.Skeyword "external";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (string_list : 'string_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (sl : 'string_list) _ (t : 'ctyp) _
- (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.SgExt (_loc, i, t, sl) : 'sig_item))));
- ([ Gram.Skeyword "exception";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'constructor_declaration) _
- (_loc : Gram.Loc.t) ->
- (Ast.SgExc (_loc, t) : 'sig_item))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.sig_item_tag :
- 'sig_item)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "sigi" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "sigi" | "anti" | "list" as n)),
- s) ->
- (Ast.SgAnt (_loc,
- (mk_anti ~c: "sig_item" n s)) :
- 'sig_item)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (module_declaration : 'module_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword ")"; Gram.Sself ],
- (Gram.Action.mk
- (fun (mt : 'module_declaration) _
- (t : 'module_type) _ (i : 'a_UIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.MtFun (_loc, i, t, mt) :
- 'module_declaration))));
- ([ Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ (_loc : Gram.Loc.t)
- -> (mt : 'module_declaration)))) ]) ]))
- ());
- Gram.extend
- (module_rec_declaration :
- 'module_rec_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ (m : 'a_UIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.MbCol (_loc, m, mt) :
- 'module_rec_declaration))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.module_binding_tag :
- 'module_rec_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT
- (("" | "module_binding" | "anti" |
- "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "module_binding" | "anti" |
- "list"
- as n)),
- s) ->
- (Ast.MbAnt (_loc,
- (mk_anti ~c: "module_binding" n s)) :
- 'module_rec_declaration)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (m2 : 'module_rec_declaration) _
- (m1 : 'module_rec_declaration)
- (_loc : Gram.Loc.t) ->
- (Ast.MbAnd (_loc, m1, m2) :
- 'module_rec_declaration)))) ]) ]))
- ());
- Gram.extend (with_constr : 'with_constr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t));
- Gram.Skeyword ":=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident_with_app :
- 'module_longident_with_app Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i2 : 'module_longident_with_app) _
- (i1 : 'module_longident) _
- (_loc : Gram.Loc.t) ->
- (Ast.WcMoS (_loc, i1, i2) : 'with_constr))));
- ([ Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (type_longident_and_parameters :
- 'type_longident_and_parameters Gram.Entry.
- t));
- Gram.Skeyword ":=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _
- (t1 : 'type_longident_and_parameters) _
- (_loc : Gram.Loc.t) ->
- (Ast.WcTyS (_loc, t1, t2) : 'with_constr))));
- ([ Gram.Skeyword "type";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)"));
- Gram.Skeyword ":=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
- ->
- (Ast.WcTyS (_loc,
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s))),
- t) :
- 'with_constr)
- | _ -> assert false)));
- ([ Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident_with_app :
- 'module_longident_with_app Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i2 : 'module_longident_with_app) _
- (i1 : 'module_longident) _
- (_loc : Gram.Loc.t) ->
- (Ast.WcMod (_loc, i1, i2) : 'with_constr))));
- ([ Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (type_longident_and_parameters :
- 'type_longident_and_parameters Gram.Entry.
- t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _
- (t1 : 'type_longident_and_parameters) _
- (_loc : Gram.Loc.t) ->
- (Ast.WcTyp (_loc, t1, t2) : 'with_constr))));
- ([ Gram.Skeyword "type";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)"));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
- ->
- (Ast.WcTyp (_loc,
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s))),
- t) :
- 'with_constr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.with_constr_tag :
- 'with_constr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT
- (("" | "with_constr" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "with_constr" | "anti" | "list"
- as n)),
- s) ->
- (Ast.WcAnt (_loc,
- (mk_anti ~c: "with_constr" n s)) :
- 'with_constr)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (wc2 : 'with_constr) _ (wc1 : 'with_constr)
- (_loc : Gram.Loc.t) ->
- (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ]))
- ());
- Gram.extend (expr : 'expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Skeyword "object";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_class_self_patt :
- 'opt_class_self_patt Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_structure :
- 'class_structure Gram.Entry.t));
- Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ (cst : 'class_structure)
- (csp : 'opt_class_self_patt) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExObj (_loc, csp, cst) : 'expr))));
- ([ Gram.Skeyword "while";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword "do";
- Gram.Snterm
- (Gram.Entry.obj
- (do_sequence : 'do_sequence Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (seq : 'do_sequence) _ (e : 'sequence) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExWhi (_loc, (mksequence' _loc e), seq) :
- 'expr))));
- ([ Gram.Skeyword "for";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (direction_flag :
- 'direction_flag Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword "do";
- Gram.Snterm
- (Gram.Entry.obj
- (do_sequence : 'do_sequence Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (seq : 'do_sequence) _ (e2 : 'sequence)
- (df : 'direction_flag) (e1 : 'sequence) _
- (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.ExFor (_loc, i, (mksequence' _loc e1),
- (mksequence' _loc e2), df, seq) :
- 'expr))));
- ([ Gram.Skeyword "do";
- Gram.Snterm
- (Gram.Entry.obj
- (do_sequence : 'do_sequence Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (seq : 'do_sequence) _ (_loc : Gram.Loc.t)
- -> (mksequence _loc seq : 'expr))));
- ([ Gram.Skeyword "if"; Gram.Sself;
- Gram.Skeyword "then"; Gram.Sself;
- Gram.Skeyword "else"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr)
- _ (_loc : Gram.Loc.t) ->
- (Ast.ExIfe (_loc, e1, e2, e3) : 'expr))));
- ([ Gram.Skeyword "try";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword "with";
- Gram.Snterm
- (Gram.Entry.obj
- (match_case : 'match_case Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (a : 'match_case) _ (e : 'sequence) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExTry (_loc, (mksequence' _loc e), a) :
- 'expr))));
- ([ Gram.Skeyword "match";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword "with";
- Gram.Snterm
- (Gram.Entry.obj
- (match_case : 'match_case Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (a : 'match_case) _ (e : 'sequence) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExMat (_loc, (mksequence' _loc e), a) :
- 'expr))));
- ([ Gram.Skeyword "fun";
- Gram.Snterm
- (Gram.Entry.obj
- (fun_def : 'fun_def Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) ->
- (e : 'expr))));
- ([ Gram.Skeyword "fun"; Gram.Skeyword "[";
- Gram.Slist0sep
- ((Gram.Snterm
- (Gram.Entry.obj
- (match_case0 :
- 'match_case0 Gram.Entry.t))),
- (Gram.Skeyword "|"));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (a : 'match_case0 list) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) :
- 'expr))));
- ([ Gram.Skeyword "let"; Gram.Skeyword "open";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t));
- Gram.Skeyword "in"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (i : 'module_longident) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.ExOpI (_loc, i, e) : 'expr))));
- ([ Gram.Skeyword "let"; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (module_binding0 :
- 'module_binding0 Gram.Entry.t));
- Gram.Skeyword "in"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (mb : 'module_binding0)
- (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExLmd (_loc, m, mb, e) : 'expr))));
- ([ Gram.Skeyword "let";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (binding : 'binding Gram.Entry.t));
- Gram.Skeyword "in"; Gram.Sself ],
- (Gram.Action.mk
- (fun (x : 'expr) _ (bi : 'binding)
- (r : 'opt_rec) _ (_loc : Gram.Loc.t) ->
- (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]);
- ((Some "where"), None,
- [ ([ Gram.Sself; Gram.Skeyword "where";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (let_binding : 'let_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (lb : 'let_binding) (rf : 'opt_rec) _
- (e : 'expr) (_loc : Gram.Loc.t) ->
- (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]);
- ((Some ":="), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (match bigarray_set _loc e1 e2 with
- | Some e -> e
- | None -> Ast.ExAss (_loc, e1, e2) : 'expr)))) ]);
- ((Some "||"), (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop6 : 'infixop6 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop6) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr)))) ]);
- ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop5 : 'infixop5 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop5) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr)))) ]);
- ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop0 : 'infixop0 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop0) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr)))) ]);
- ((Some "^"), (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop1 : 'infixop1 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop1) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr)))) ]);
- ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop2 : 'infixop2 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop2) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr)))) ]);
- ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop3 : 'infixop3 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop3) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "mod")))),
- e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "lxor")))),
- e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "lor")))),
- e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "land")))),
- e1)),
- e2) :
- 'expr)))) ]);
- ((Some "**"), (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Sself;
- Gram.Snterm
- (Gram.Entry.obj
- (infixop4 : 'infixop4 Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (op : 'infixop4) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "lsr")))),
- e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "lsl")))),
- e1)),
- e2) :
- 'expr))));
- ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "asr")))),
- e1)),
- e2) :
- 'expr)))) ]);
- ((Some "unary minus"), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Skeyword "-."; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (mkumin _loc "-." e : 'expr))));
- ([ Gram.Skeyword "-"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (mkumin _loc "-" e : 'expr)))) ]);
- ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Skeyword "lazy"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (Ast.ExLaz (_loc, e) : 'expr))));
- ([ Gram.Skeyword "new";
- Gram.Snterm
- (Gram.Entry.obj
- (class_longident :
- 'class_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'class_longident) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExNew (_loc, i) : 'expr))));
- ([ Gram.Skeyword "assert"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (mkassert _loc e : 'expr))));
- ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]);
- ((Some "label"), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Skeyword "?";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) :
- 'expr))));
- ([ Gram.Skeyword "?";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (i : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExOlb (_loc, i, e) : 'expr))));
- ([ Gram.Stoken
- (((function | OPTLABEL _ -> true | _ -> false),
- "OPTLABEL _"));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | OPTLABEL i ->
- (Ast.ExOlb (_loc, i, e) : 'expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | LABEL _ -> true | _ -> false),
- "LABEL _"));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LABEL i -> (Ast.ExLab (_loc, i, e) : 'expr)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) :
- 'expr))));
- ([ Gram.Skeyword "~";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (i : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExLab (_loc, i, e) : 'expr)))) ]);
- ((Some "."), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself; Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (lab : 'label) _ (e : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExSnd (_loc, e, lab) : 'expr))));
- ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExAcc (_loc, e1, e2) : 'expr))));
- ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "{";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_expr : 'comma_expr Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (bigarray_get _loc e1 e2 : 'expr))));
- ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "[";
- Gram.Sself; Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (e2 : 'expr) _ _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExSte (_loc, e1, e2) : 'expr))));
- ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "(";
- Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (e2 : 'expr) _ _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]);
- ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (prefixop : 'prefixop Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) (f : 'prefixop)
- (_loc : Gram.Loc.t) ->
- (Ast.ExApp (_loc, f, e) : 'expr))));
- ([ Gram.Skeyword "!"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (Ast.ExAcc (_loc, e,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, "val"))))) :
- 'expr)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (package_type : 'package_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (pt : 'package_type) _
- (me : 'module_expr) _ _ (_loc : Gram.Loc.t)
- ->
- (Ast.ExPkg (_loc, (Ast.MeTyc (_loc, me, pt))) :
- 'expr))));
- ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (me : 'module_expr) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.ExPkg (_loc, me) : 'expr))));
- ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
- 'expr))));
- ([ Gram.Skeyword "begin";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t)
- -> (mksequence _loc seq : 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (e : 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself;
- Gram.Skeyword ":>";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (e : 'expr) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) :
- 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ":>";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr)
- _ (_loc : Gram.Loc.t) ->
- (Ast.ExCoe (_loc, e, t, t2) : 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";";
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (mksequence _loc e : 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (seq : 'sequence) _ (e : 'expr) _
- (_loc : Gram.Loc.t) ->
- (mksequence _loc (Ast.ExSem (_loc, e, seq)) :
- 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ",";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_expr : 'comma_expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (el : 'comma_expr) _ (e : 'expr) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExTup (_loc, (Ast.ExCom (_loc, e, el))) :
- 'expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (e : 'expr) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExTyc (_loc, e, t) : 'expr))));
- ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
- 'expr))));
- ([ Gram.Skeyword "{<";
- Gram.Snterm
- (Gram.Entry.obj
- (field_expr_list :
- 'field_expr_list Gram.Entry.t));
- Gram.Skeyword ">}" ],
- (Gram.Action.mk
- (fun _ (fel : 'field_expr_list) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExOvr (_loc, fel) : 'expr))));
- ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExOvr (_loc, (Ast.RbNil _loc)) : 'expr))));
- ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram.Sself;
- Gram.Skeyword ")"; Gram.Skeyword "with";
- Gram.Snterm
- (Gram.Entry.obj
- (label_expr_list :
- 'label_expr_list Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (el : 'label_expr_list) _ _ (e : 'expr) _
- _ (_loc : Gram.Loc.t) ->
- (Ast.ExRec (_loc, el, e) : 'expr))));
- ([ Gram.Skeyword "{";
- Gram.Snterm
- (Gram.Entry.obj
- (label_expr_list :
- 'label_expr_list Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (el : 'label_expr_list) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) :
- 'expr))));
- ([ Gram.Skeyword "[|";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_expr : 'sem_expr Gram.Entry.t));
- Gram.Skeyword "|]" ],
- (Gram.Action.mk
- (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t) ->
- (Ast.ExArr (_loc, el) : 'expr))));
- ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExArr (_loc, (Ast.ExNil _loc)) : 'expr))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_expr_for_list :
- 'sem_expr_for_list Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (mk_list : 'sem_expr_for_list) _
- (_loc : Gram.Loc.t) ->
- (mk_list
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) :
- 'expr))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_expr_for_list :
- 'sem_expr_for_list Gram.Entry.t));
- Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (last : 'expr) _
- (mk_list : 'sem_expr_for_list) _
- (_loc : Gram.Loc.t) -> (mk_list last : 'expr))));
- ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) :
- 'expr))));
- ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.ExVrn (_loc, s) : 'expr))));
- ([ Gram.Stry
- (Gram.Snterm
- (Gram.Entry.obj
- (val_longident :
- 'val_longident Gram.Entry.t))) ],
- (Gram.Action.mk
- (fun (i : 'val_longident) (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, i) : 'expr))));
- ([ Gram.Stry
- (Gram.Snterm
- (Gram.Entry.obj
- (module_longident_dot_lparen :
- 'module_longident_dot_lparen Gram.
- Entry.t)));
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (e : 'sequence)
- (i : 'module_longident_dot_lparen)
- (_loc : Gram.Loc.t) ->
- (Ast.ExOpI (_loc, i, e) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) ->
- (Ast.ExChr (_loc, s) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_STRING : 'a_STRING Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_STRING) (_loc : Gram.Loc.t) ->
- (Ast.ExStr (_loc, s) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) ->
- (Ast.ExFlo (_loc, s) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) ->
- (Ast.ExNativeInt (_loc, s) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_INT64 : 'a_INT64 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT64) (_loc : Gram.Loc.t) ->
- (Ast.ExInt64 (_loc, s) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_INT32 : 'a_INT32 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT32) (_loc : Gram.Loc.t) ->
- (Ast.ExInt32 (_loc, s) : 'expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT) (_loc : Gram.Loc.t) ->
- (Ast.ExInt (_loc, s) : 'expr))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("seq", _) -> true
- | _ -> false),
- "ANTIQUOT (\"seq\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("seq" as n)), s) ->
- (Ast.ExSeq (_loc,
- (Ast.ExAnt (_loc,
- (mk_anti ~c: "expr" n s)))) :
- 'expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("tup", _) -> true
- | _ -> false),
- "ANTIQUOT (\"tup\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("tup" as n)), s) ->
- (Ast.ExTup (_loc,
- (Ast.ExAnt (_loc,
- (mk_anti ~c: "expr" n s)))) :
- 'expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("`bool", _) -> true
- | _ -> false),
- "ANTIQUOT (\"`bool\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("`bool" as n)), s) ->
- (Ast.ExId (_loc,
- (Ast.IdAnt (_loc, (mk_anti n s)))) :
- 'expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("exp" | "" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("exp" | "" | "anti" as n)), s)
- ->
- (Ast.ExAnt (_loc,
- (mk_anti ~c: "expr" n s)) :
- 'expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.expr_tag :
- 'expr)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (do_sequence : 'do_sequence Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "done" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
- 'do_sequence))));
- ([ Gram.Stry
- (Gram.srules do_sequence
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (sequence :
- 'sequence Gram.Entry.t));
- Gram.Skeyword "done" ],
- (Gram.Action.mk
- (fun _ (seq : 'sequence)
- (_loc : Gram.Loc.t) ->
- (seq : 'e__3)))) ]) ],
- (Gram.Action.mk
- (fun (seq : 'e__3) (_loc : Gram.Loc.t) ->
- (seq : 'do_sequence))));
- ([ Gram.Stry
- (Gram.srules do_sequence
- [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (() : 'e__2)))) ]) ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
- 'do_sequence))));
- ([ Gram.Stry
- (Gram.srules do_sequence
- [ ([ Gram.Skeyword "{";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence :
- 'sequence Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (seq : 'sequence) _
- (_loc : Gram.Loc.t) ->
- (seq : 'e__1)))) ]) ],
- (Gram.Action.mk
- (fun (seq : 'e__1) (_loc : Gram.Loc.t) ->
- (seq : 'do_sequence)))) ]) ]))
- ());
- Gram.extend (infixop5 : 'infixop5 Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.srules infixop5
- [ ([ Gram.Skeyword "&&" ],
- (Gram.Action.mk
- (fun (x : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- (Gram.Token.extract_string x : 'e__4))));
- ([ Gram.Skeyword "&" ],
- (Gram.Action.mk
- (fun (x : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- (Gram.Token.extract_string x : 'e__4)))) ] ],
- (Gram.Action.mk
- (fun (x : 'e__4) (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) :
- 'infixop5)))) ]) ]))
- ());
- Gram.extend (infixop6 : 'infixop6 Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.srules infixop6
- [ ([ Gram.Skeyword "||" ],
- (Gram.Action.mk
- (fun (x : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- (Gram.Token.extract_string x : 'e__5))));
- ([ Gram.Skeyword "or" ],
- (Gram.Action.mk
- (fun (x : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- (Gram.Token.extract_string x : 'e__5)))) ] ],
- (Gram.Action.mk
- (fun (x : 'e__5) (_loc : Gram.Loc.t) ->
- (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) :
- 'infixop6)))) ]) ]))
- ());
- Gram.extend
- (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) (_loc : Gram.Loc.t) ->
- (fun acc ->
- Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdUid (_loc, "::")))),
- e)),
- acc) :
- 'sem_expr_for_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (e : 'expr) (_loc : Gram.Loc.t) ->
- (fun acc ->
- Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdUid (_loc, "::")))),
- e)),
- acc) :
- 'sem_expr_for_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (el : 'sem_expr_for_list) _ (e : 'expr)
- (_loc : Gram.Loc.t) ->
- (fun acc ->
- Ast.ExApp (_loc,
- (Ast.ExApp (_loc,
- (Ast.ExId (_loc,
- (Ast.IdUid (_loc, "::")))),
- e)),
- (el acc)) :
- 'sem_expr_for_list)))) ]) ]))
- ());
- Gram.extend (comma_expr : 'comma_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterml
- ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
- "top") ],
- (Gram.Action.mk
- (fun (e : 'expr) (_loc : Gram.Loc.t) ->
- (e : 'comma_expr))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.ExAnt (_loc,
- (mk_anti ~c: "expr," n s)) :
- 'comma_expr)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
- (Gram.Action.mk
- (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ]))
- ());
- Gram.extend (dummy : 'dummy Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ]))
- ());
- Gram.extend (sequence' : 'sequence' Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (sequence : 'sequence Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (el : 'sequence) _ (_loc : Gram.Loc.t) ->
- (fun e -> Ast.ExSem (_loc, e, el) :
- 'sequence'))));
- ([ Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (fun e -> e : 'sequence'))));
- ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (fun e -> e : 'sequence')))) ]) ]))
- ());
- Gram.extend (sequence : 'sequence Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (sequence' : 'sequence' Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (k : 'sequence') (e : 'expr)
- (_loc : Gram.Loc.t) -> (k e : 'sequence))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.ExAnt (_loc,
- (mk_anti ~c: "expr;" n s)) :
- 'sequence)
- | _ -> assert false)));
- ([ Gram.Skeyword "let"; Gram.Skeyword "open";
- Gram.Snterm
- (Gram.Entry.obj
- (module_longident :
- 'module_longident Gram.Entry.t));
- Gram.Skeyword "in"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'sequence) _ (i : 'module_longident) _
- _ (_loc : Gram.Loc.t) ->
- (Ast.ExOpI (_loc, i, e) : 'sequence))));
- ([ Gram.Skeyword "let"; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (module_binding0 :
- 'module_binding0 Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (el : 'sequence) _ (mb : 'module_binding0)
- (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
- (Ast.ExLmd (_loc, m, mb,
- (mksequence _loc el)) :
- 'sequence))));
- ([ Gram.Skeyword "let"; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (module_binding0 :
- 'module_binding0 Gram.Entry.t));
- Gram.Skeyword "in";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (sequence' : 'sequence' Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (k : 'sequence') (e : 'expr) _
- (mb : 'module_binding0) (m : 'a_UIDENT) _ _
- (_loc : Gram.Loc.t) ->
- (k (Ast.ExLmd (_loc, m, mb, e)) : 'sequence))));
- ([ Gram.Skeyword "let";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (binding : 'binding Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (el : 'sequence) _ (bi : 'binding)
- (rf : 'opt_rec) _ (_loc : Gram.Loc.t) ->
- (Ast.ExLet (_loc, rf, bi,
- (mksequence _loc el)) :
- 'sequence))));
- ([ Gram.Skeyword "let";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (binding : 'binding Gram.Entry.t));
- Gram.Skeyword "in";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (sequence' : 'sequence' Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (k : 'sequence') (e : 'expr) _
- (bi : 'binding) (rf : 'opt_rec) _
- (_loc : Gram.Loc.t) ->
- (k (Ast.ExLet (_loc, rf, bi, e)) : 'sequence)))) ]) ]))
- ());
- Gram.extend (binding : 'binding Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (let_binding : 'let_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (b : 'let_binding) (_loc : Gram.Loc.t) ->
- (b : 'binding))));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (b2 : 'binding) _ (b1 : 'binding)
- (_loc : Gram.Loc.t) ->
- (Ast.BiAnd (_loc, b1, b2) : 'binding))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.BiAnt (_loc,
- (mk_anti ~c: "binding" n s)) :
- 'binding)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)"));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.BiEq (_loc,
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s))),
- e) :
- 'binding)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("binding" | "list"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"binding\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("binding" | "list" as n)), s)
- ->
- (Ast.BiAnt (_loc,
- (mk_anti ~c: "binding" n s)) :
- 'binding)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (let_binding : 'let_binding Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (fun_binding : 'fun_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'fun_binding) (p : 'ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ]))
- ());
- Gram.extend (fun_binding : 'fun_binding Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (cvalue_binding :
- 'cvalue_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t)
- -> (bi : 'fun_binding))));
- ([ Gram.Stry
- (Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t)));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'fun_binding) (p : 'labeled_ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.ExFun (_loc,
- (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) :
- 'fun_binding))));
- ([ Gram.Stry
- (Gram.srules fun_binding
- [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (() : 'e__6)))) ]);
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ")"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ]))
- ());
- Gram.extend (match_case : 'match_case Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t));
- Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (p : 'ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) :
- 'match_case))));
- ([ Gram.Skeyword "[";
- Gram.Slist0sep
- ((Gram.Snterm
- (Gram.Entry.obj
- (match_case0 :
- 'match_case0 Gram.Entry.t))),
- (Gram.Skeyword "|"));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (l : 'match_case0 list) _
- (_loc : Gram.Loc.t) ->
- (Ast.mcOr_of_list l : 'match_case)))) ]) ]))
- ());
- Gram.extend (match_case0 : 'match_case0 Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (patt_as_patt_opt :
- 'patt_as_patt_opt Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_when_expr :
- 'opt_when_expr Gram.Entry.t));
- Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (w : 'opt_when_expr)
- (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t)
- -> (Ast.McArr (_loc, p, w, e) : 'match_case0))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)"));
- Gram.Skeyword "when";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (w : 'expr) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.McArr (_loc,
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s))),
- w, e) :
- 'match_case0)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)"));
- Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.McArr (_loc,
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s))),
- (Ast.ExNil _loc), e) :
- 'match_case0)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.McAnt (_loc,
- (mk_anti ~c: "match_case" n s)) :
- 'match_case0)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("match_case" | "list"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("match_case" | "list" as n)),
- s) ->
- (Ast.McAnt (_loc,
- (mk_anti ~c: "match_case" n s)) :
- 'match_case0)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.ExNil _loc : 'opt_when_expr))));
- ([ Gram.Skeyword "when";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (w : 'expr) _ (_loc : Gram.Loc.t) ->
- (w : 'opt_when_expr)))) ]) ]))
- ());
- Gram.extend (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'patt) (_loc : Gram.Loc.t) ->
- (p : 'patt_as_patt_opt))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword "as";
- Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p2 : 'patt) _ (p1 : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaAli (_loc, p1, p2) :
- 'patt_as_patt_opt)))) ]) ]))
- ());
- Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_expr : 'label_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) ->
- (b1 : 'label_expr_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_expr : 'label_expr Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) ->
- (b1 : 'label_expr_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_expr : 'label_expr Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (b2 : 'label_expr_list) _
- (b1 : 'label_expr) (_loc : Gram.Loc.t) ->
- (Ast.RbSem (_loc, b1, b2) : 'label_expr_list)))) ]) ]))
- ());
- Gram.extend (label_expr : 'label_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_longident :
- 'label_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'label_longident) (_loc : Gram.Loc.t)
- ->
- (Ast.RbEq (_loc, i,
- (Ast.ExId (_loc,
- (Ast.IdLid (_loc, (lid_of_ident i)))))) :
- 'label_expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_longident :
- 'label_longident Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (fun_binding : 'fun_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'fun_binding) (i : 'label_longident)
- (_loc : Gram.Loc.t) ->
- (Ast.RbEq (_loc, i, e) : 'label_expr))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.RbAnt (_loc,
- (mk_anti ~c: "rec_binding" n s)) :
- 'label_expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)"));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.RbEq (_loc,
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s))),
- e) :
- 'label_expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "anti" as n)), s) ->
- (Ast.RbAnt (_loc,
- (mk_anti ~c: "rec_binding" n s)) :
- 'label_expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("rec_binding", _) -> true
- | _ -> false),
- "ANTIQUOT (\"rec_binding\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("rec_binding" as n)), s) ->
- (Ast.RbAnt (_loc,
- (mk_anti ~c: "rec_binding" n s)) :
- 'label_expr)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (fun_def : 'fun_def Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stry
- (Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t)));
- Gram.Snterm
- (Gram.Entry.obj
- (fun_def_cont : 'fun_def_cont Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((w, e) : 'fun_def_cont)
- (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
- (Ast.ExFun (_loc,
- (Ast.McArr (_loc, p, w, e))) :
- 'fun_def))));
- ([ Gram.Stry
- (Gram.srules fun_def
- [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (() : 'e__7)))) ]);
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ")";
- Gram.Snterm
- (Gram.Entry.obj
- (fun_def_cont_no_when :
- 'fun_def_cont_no_when Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'fun_def_cont_no_when) _
- (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ]))
- ());
- Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (((Ast.ExNil _loc), e) : 'fun_def_cont))));
- ([ Gram.Skeyword "when";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (w : 'expr) _
- (_loc : Gram.Loc.t) ->
- ((w, e) : 'fun_def_cont))));
- ([ Gram.Stry
- (Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t)));
- Gram.Sself ],
- (Gram.Action.mk
- (fun ((w, e) : 'fun_def_cont)
- (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
- (((Ast.ExNil _loc),
- (Ast.ExFun (_loc,
- (Ast.McArr (_loc, p, w, e))))) :
- 'fun_def_cont))));
- ([ Gram.Stry
- (Gram.srules fun_def_cont
- [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (() : 'e__8)))) ]);
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ")";
- Gram.Snterm
- (Gram.Entry.obj
- (fun_def_cont_no_when :
- 'fun_def_cont_no_when Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'fun_def_cont_no_when) _
- (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (((Ast.ExNil _loc), (Ast.ExFUN (_loc, i, e))) :
- 'fun_def_cont)))) ]) ]))
- ());
- Gram.extend
- (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (e : 'fun_def_cont_no_when))));
- ([ Gram.Stry
- (Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t)));
- Gram.Snterm
- (Gram.Entry.obj
- (fun_def_cont : 'fun_def_cont Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((w, e) : 'fun_def_cont)
- (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
- (Ast.ExFun (_loc,
- (Ast.McArr (_loc, p, w, e))) :
- 'fun_def_cont_no_when))));
- ([ Gram.Stry
- (Gram.srules fun_def_cont_no_when
- [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (() : 'e__9)))) ]);
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ")"; Gram.Sself ],
- (Gram.Action.mk
- (fun (e : 'fun_def_cont_no_when) _
- (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (Ast.ExFUN (_loc, i, e) :
- 'fun_def_cont_no_when)))) ]) ]))
- ());
- Gram.extend (patt : 'patt Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'patt) _ (p1 : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]);
- ((Some ".."), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'patt) _ (p1 : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]);
- ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Skeyword "lazy"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p : 'patt) _ (_loc : Gram.Loc.t) ->
- (Ast.PaLaz (_loc, p) : 'patt))));
- ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'patt) (p1 : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "?"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (patt_tcon : 'patt_tcon Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.PaOlbi (_loc, "", p, e) : 'patt))));
- ([ Gram.Skeyword "?"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (patt_tcon : 'patt_tcon Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'patt_tcon) _ _ (_loc : Gram.Loc.t)
- -> (Ast.PaOlb (_loc, "", p) : 'patt))));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (Ast.PaOlb (_loc, (mk_anti n i),
- (Ast.PaNil _loc)) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function | LIDENT _ -> true | _ -> false),
- "LIDENT _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LIDENT i ->
- (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)"));
- Gram.Skeyword ":"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (patt_tcon : 'patt_tcon Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (eq_expr : 'eq_expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _
- (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (f (mk_anti n i) p : 'patt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | OPTLABEL _ -> true | _ -> false),
- "OPTLABEL _"));
- Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (patt_tcon : 'patt_tcon Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (eq_expr : 'eq_expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (f : 'eq_expr) (p : 'patt_tcon) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | OPTLABEL i -> (f i p : 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function | LIDENT _ -> true | _ -> false),
- "LIDENT _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LIDENT i ->
- (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (Ast.PaLab (_loc, (mk_anti n i),
- (Ast.PaNil _loc)) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)"));
- Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (Ast.PaLab (_loc, (mk_anti n i), p) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | LABEL _ -> true | _ -> false),
- "LABEL _"));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (p : 'patt) (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LABEL i -> (Ast.PaLab (_loc, i, p) : 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (type_longident :
- 'type_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'type_longident) _ (_loc : Gram.Loc.t)
- -> (Ast.PaTyp (_loc, i) : 'patt))));
- ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.PaVrn (_loc, s) : 'patt))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.patt_tag :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.PaAny _loc : 'patt))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ",";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_patt : 'comma_patt Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (pl : 'comma_patt) _ (p : 'patt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaTup (_loc, (Ast.PaCom (_loc, p, pl))) :
- 'patt))));
- ([ Gram.Skeyword "("; Gram.Sself;
- Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p2 : 'patt) _ (p : 'patt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaAli (_loc, p, p2) : 'patt))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (p : 'patt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, p, t) : 'patt))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
- (p : 'patt))));
- ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (package_type : 'package_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
- _ (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
- (Ast.TyPkg (_loc, pt))) :
- 'patt))));
- ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
- -> (Ast.PaMod (_loc, m) : 'patt))));
- ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) :
- 'patt))));
- ([ Gram.Skeyword "{";
- Gram.Snterm
- (Gram.Entry.obj
- (label_patt_list :
- 'label_patt_list Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (pl : 'label_patt_list) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaRec (_loc, pl) : 'patt))));
- ([ Gram.Skeyword "[|";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_patt : 'sem_patt Gram.Entry.t));
- Gram.Skeyword "|]" ],
- (Gram.Action.mk
- (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t) ->
- (Ast.PaArr (_loc, pl) : 'patt))));
- ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.PaArr (_loc, (Ast.PaNil _loc)) : 'patt))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_patt_for_list :
- 'sem_patt_for_list Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (mk_list : 'sem_patt_for_list) _
- (_loc : Gram.Loc.t) ->
- (mk_list
- (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]")))) :
- 'patt))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_patt_for_list :
- 'sem_patt_for_list Gram.Entry.t));
- Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (last : 'patt) _
- (mk_list : 'sem_patt_for_list) _
- (_loc : Gram.Loc.t) -> (mk_list last : 'patt))));
- ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) :
- 'patt))));
- ([ Gram.Skeyword "-";
- Gram.Snterm
- (Gram.Entry.obj
- (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) ->
- (Ast.PaFlo (_loc, (neg_string s)) : 'patt))));
- ([ Gram.Skeyword "-";
- Gram.Snterm
- (Gram.Entry.obj
- (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t) ->
- (Ast.PaNativeInt (_loc, (neg_string s)) :
- 'patt))));
- ([ Gram.Skeyword "-";
- Gram.Snterm
- (Gram.Entry.obj
- (a_INT64 : 'a_INT64 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) ->
- (Ast.PaInt64 (_loc, (neg_string s)) : 'patt))));
- ([ Gram.Skeyword "-";
- Gram.Snterm
- (Gram.Entry.obj
- (a_INT32 : 'a_INT32 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) ->
- (Ast.PaInt32 (_loc, (neg_string s)) : 'patt))));
- ([ Gram.Skeyword "-";
- Gram.Snterm
- (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) ->
- (Ast.PaInt (_loc, (neg_string s)) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) ->
- (Ast.PaChr (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_STRING : 'a_STRING Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_STRING) (_loc : Gram.Loc.t) ->
- (Ast.PaStr (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) ->
- (Ast.PaFlo (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) ->
- (Ast.PaNativeInt (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_INT64 : 'a_INT64 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT64) (_loc : Gram.Loc.t) ->
- (Ast.PaInt64 (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_INT32 : 'a_INT32 Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT32) (_loc : Gram.Loc.t) ->
- (Ast.PaInt32 (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_INT) (_loc : Gram.Loc.t) ->
- (Ast.PaInt (_loc, s) : 'patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'ident) (_loc : Gram.Loc.t) ->
- (Ast.PaId (_loc, i) : 'patt))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("`bool", _) -> true
- | _ -> false),
- "ANTIQUOT (\"`bool\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("`bool" as n)), s) ->
- (Ast.PaId (_loc,
- (Ast.IdAnt (_loc, (mk_anti n s)))) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("tup", _) -> true
- | _ -> false),
- "ANTIQUOT (\"tup\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("tup" as n)), s) ->
- (Ast.PaTup (_loc,
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s)))) :
- 'patt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "pat" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "pat" | "anti" as n)), s)
- ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s)) :
- 'patt)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (comma_patt : 'comma_patt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'patt) (_loc : Gram.Loc.t) ->
- (p : 'comma_patt))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt," n s)) :
- 'comma_patt)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ]))
- ());
- Gram.extend (sem_patt : 'sem_patt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'patt) (_loc : Gram.Loc.t) ->
- (p : 'sem_patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (p : 'patt) (_loc : Gram.Loc.t) ->
- (p : 'sem_patt))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt;" n s)) :
- 'sem_patt)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'sem_patt) _ (p1 : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ]))
- ());
- Gram.extend
- (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'patt) (_loc : Gram.Loc.t) ->
- (fun acc ->
- Ast.PaApp (_loc,
- (Ast.PaApp (_loc,
- (Ast.PaId (_loc,
- (Ast.IdUid (_loc, "::")))),
- p)),
- acc) :
- 'sem_patt_for_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (p : 'patt) (_loc : Gram.Loc.t) ->
- (fun acc ->
- Ast.PaApp (_loc,
- (Ast.PaApp (_loc,
- (Ast.PaId (_loc,
- (Ast.IdUid (_loc, "::")))),
- p)),
- acc) :
- 'sem_patt_for_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (pl : 'sem_patt_for_list) _ (p : 'patt)
- (_loc : Gram.Loc.t) ->
- (fun acc ->
- Ast.PaApp (_loc,
- (Ast.PaApp (_loc,
- (Ast.PaId (_loc,
- (Ast.IdUid (_loc, "::")))),
- p)),
- (pl acc)) :
- 'sem_patt_for_list)))) ]) ]))
- ());
- Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_patt : 'label_patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) ->
- (p1 : 'label_patt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_patt : 'label_patt Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) ->
- (p1 : 'label_patt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_patt : 'label_patt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Skeyword "_";
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ _ _ (p1 : 'label_patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
- 'label_patt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_patt : 'label_patt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ _ (p1 : 'label_patt) (_loc : Gram.Loc.t)
- ->
- (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
- 'label_patt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_patt : 'label_patt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'label_patt_list) _
- (p1 : 'label_patt) (_loc : Gram.Loc.t) ->
- (Ast.PaSem (_loc, p1, p2) : 'label_patt_list)))) ]) ]))
- ());
- Gram.extend (label_patt : 'label_patt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_longident :
- 'label_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'label_longident) (_loc : Gram.Loc.t)
- ->
- (Ast.PaEq (_loc, i,
- (Ast.PaId (_loc,
- (Ast.IdLid (_loc, (lid_of_ident i)))))) :
- 'label_patt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_longident :
- 'label_longident Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'patt) _ (i : 'label_longident)
- (_loc : Gram.Loc.t) ->
- (Ast.PaEq (_loc, i, p) : 'label_patt))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt;" n s)) :
- 'label_patt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.patt_tag :
- 'label_patt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "pat" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "pat" | "anti" as n)), s)
- ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s)) :
- 'label_patt)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (ipatt : 'ipatt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.PaAny _loc : 'ipatt))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) :
- 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ",";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_ipatt : 'comma_ipatt Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaTup (_loc, (Ast.PaCom (_loc, p, pl))) :
- 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Sself;
- Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaAli (_loc, p, p2) : 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (p : 'ipatt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, p, t) : 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) ->
- (p : 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (package_type : 'package_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
- _ (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
- (Ast.TyPkg (_loc, pt))) :
- 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
- -> (Ast.PaMod (_loc, m) : 'ipatt))));
- ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) :
- 'ipatt))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.patt_tag :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("tup", _) -> true
- | _ -> false),
- "ANTIQUOT (\"tup\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("tup" as n)), s) ->
- (Ast.PaTup (_loc,
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s)))) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "pat" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "pat" | "anti" as n)), s)
- ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s)) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Skeyword "{";
- Gram.Snterm
- (Gram.Entry.obj
- (label_ipatt_list :
- 'label_ipatt_list Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (pl : 'label_ipatt_list) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ]))
- ());
- Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'ipatt) (_loc : Gram.Loc.t) ->
- (p : 'labeled_ipatt)))) ]) ]))
- ());
- Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'ipatt) (_loc : Gram.Loc.t) ->
- (p : 'comma_ipatt))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt," n s)) :
- 'comma_ipatt)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ]))
- ());
- Gram.extend (label_ipatt_list : 'label_ipatt_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_ipatt : 'label_ipatt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) ->
- (p1 : 'label_ipatt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_ipatt : 'label_ipatt Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t)
- -> (p1 : 'label_ipatt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_ipatt : 'label_ipatt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Skeyword "_";
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ _ _ (p1 : 'label_ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
- 'label_ipatt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_ipatt : 'label_ipatt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t)
- ->
- (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
- 'label_ipatt_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_ipatt : 'label_ipatt Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p2 : 'label_ipatt_list) _
- (p1 : 'label_ipatt) (_loc : Gram.Loc.t) ->
- (Ast.PaSem (_loc, p1, p2) :
- 'label_ipatt_list)))) ]) ]))
- ());
- Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_longident :
- 'label_longident Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'ipatt) _ (i : 'label_longident)
- (_loc : Gram.Loc.t) ->
- (Ast.PaEq (_loc, i, p) : 'label_ipatt))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.patt_tag :
- 'label_ipatt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt;" n s)) :
- 'label_ipatt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "pat" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "pat" | "anti" as n)), s)
- ->
- (Ast.PaAnt (_loc,
- (mk_anti ~c: "patt" n s)) :
- 'label_ipatt)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (type_declaration : 'type_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (type_ident_and_parameters :
- 'type_ident_and_parameters Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t));
- Gram.Slist0
- (Gram.Snterm
- (Gram.Entry.obj
- (constrain : 'constrain Gram.Entry.t))) ],
- (Gram.Action.mk
- (fun (cl : 'constrain list) (tk : 'opt_eq_ctyp)
- ((n, tpl) : 'type_ident_and_parameters)
- (_loc : Gram.Loc.t) ->
- (Ast.TyDcl (_loc, n, tpl, tk, cl) :
- 'type_declaration))));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'type_declaration) _
- (t1 : 'type_declaration) (_loc : Gram.Loc.t)
- ->
- (Ast.TyAnd (_loc, t1, t2) :
- 'type_declaration))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'type_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctypand" n s)) :
- 'type_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
- ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'type_declaration)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (constrain : 'constrain Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "constraint";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (_loc : Gram.Loc.t) ->
- ((t1, t2) : 'constrain)))) ]) ]))
- ());
- Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.TyNil _loc : 'opt_eq_ctyp))));
- ([ Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (type_kind : 'type_kind Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t) ->
- (tk : 'opt_eq_ctyp)))) ]) ]))
- ());
- Gram.extend (type_kind : 'type_kind Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'type_kind)))) ]) ]))
- ());
- Gram.extend
- (type_ident_and_parameters :
- 'type_ident_and_parameters Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Slist0
- (Gram.Snterm
- (Gram.Entry.obj
- (optional_type_parameter :
- 'optional_type_parameter Gram.Entry.t))) ],
- (Gram.Action.mk
- (fun (tpl : 'optional_type_parameter list)
- (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- ((i, tpl) : 'type_ident_and_parameters)))) ]) ]))
- ());
- Gram.extend
- (type_longident_and_parameters :
- 'type_longident_and_parameters Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (type_longident :
- 'type_longident Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (type_parameters :
- 'type_parameters Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (tpl : 'type_parameters)
- (i : 'type_longident) (_loc : Gram.Loc.t) ->
- (tpl (Ast.TyId (_loc, i)) :
- 'type_longident_and_parameters)))) ]) ]))
- ());
- Gram.extend (type_parameters : 'type_parameters Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (fun t -> t : 'type_parameters))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (type_parameter :
- 'type_parameter Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'type_parameter) (_loc : Gram.Loc.t)
- ->
- (fun acc -> Ast.TyApp (_loc, acc, t) :
- 'type_parameters))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (type_parameter :
- 'type_parameter Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'type_parameters)
- (t1 : 'type_parameter) (_loc : Gram.Loc.t) ->
- (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) :
- 'type_parameters)))) ]) ]))
- ());
- Gram.extend (type_parameter : 'type_parameter Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "-"; Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuM (_loc, i) : 'type_parameter))));
- ([ Gram.Skeyword "+"; Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuP (_loc, i) : 'type_parameter))));
- ([ Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuo (_loc, i) : 'type_parameter))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'type_parameter)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
- ->
- (Ast.TyAnt (_loc, (mk_anti n s)) :
- 'type_parameter)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (optional_type_parameter :
- 'optional_type_parameter Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.TyAny _loc : 'optional_type_parameter))));
- ([ Gram.Skeyword "-"; Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyAnM _loc : 'optional_type_parameter))));
- ([ Gram.Skeyword "+"; Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyAnP _loc : 'optional_type_parameter))));
- ([ Gram.Skeyword "-"; Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuM (_loc, i) :
- 'optional_type_parameter))));
- ([ Gram.Skeyword "+"; Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuP (_loc, i) :
- 'optional_type_parameter))));
- ([ Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuo (_loc, i) :
- 'optional_type_parameter))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'optional_type_parameter)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
- ->
- (Ast.TyAnt (_loc, (mk_anti n s)) :
- 'optional_type_parameter)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (ctyp : 'ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]);
- ((Some "private"), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Skeyword "private";
- Gram.Snterml
- ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)),
- "alias") ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
- (Ast.TyPrv (_loc, t) : 'ctyp)))) ]);
- ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]);
- ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Skeyword "!";
- Gram.Snterm
- (Gram.Entry.obj
- (typevars : 'typevars Gram.Entry.t));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'typevars) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]);
- ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA),
- [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]);
- ((Some "label"), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (i : 'a_OPTLABEL)
- (_loc : Gram.Loc.t) ->
- (Ast.TyOlb (_loc, i, t) : 'ctyp))));
- ([ Gram.Skeyword "?";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (i : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyOlb (_loc, i, t) : 'ctyp))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LABEL : 'a_LABEL Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (i : 'a_LABEL)
- (_loc : Gram.Loc.t) ->
- (Ast.TyLab (_loc, i, t) : 'ctyp))));
- ([ Gram.Skeyword "~";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (i : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]);
- ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) (t1 : 'ctyp)
- (_loc : Gram.Loc.t) ->
- (let t = Ast.TyApp (_loc, t1, t2)
- in
- try Ast.TyId (_loc, (Ast.ident_of_ctyp t))
- with | Invalid_argument _ -> t :
- 'ctyp)))) ]);
- ((Some "."), (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (_loc : Gram.Loc.t) ->
- (try
- Ast.TyId (_loc,
- (Ast.IdAcc (_loc,
- (Ast.ident_of_ctyp t1),
- (Ast.ident_of_ctyp t2))))
- with
- | Invalid_argument s ->
- raise (Stream.Error s) :
- 'ctyp)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "("; Gram.Skeyword "module";
- Gram.Snterm
- (Gram.Entry.obj
- (package_type : 'package_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'package_type) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.TyPkg (_loc, p) : 'ctyp))));
- ([ Gram.Skeyword "<";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_meth_list :
- 'opt_meth_list Gram.Entry.t));
- Gram.Skeyword ">" ],
- (Gram.Action.mk
- (fun _ (t : 'opt_meth_list) _
- (_loc : Gram.Loc.t) -> (t : 'ctyp))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (class_longident :
- 'class_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'class_longident) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyCls (_loc, i) : 'ctyp))));
- ([ Gram.Skeyword "{";
- Gram.Snterm
- (Gram.Entry.obj
- (label_declaration_list :
- 'label_declaration_list Gram.Entry.t));
- Gram.Skeyword "}" ],
- (Gram.Action.mk
- (fun _ (t : 'label_declaration_list) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyRec (_loc, t) : 'ctyp))));
- ([ Gram.Skeyword "[<";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t));
- Gram.Skeyword ">";
- Gram.Snterm
- (Gram.Entry.obj
- (name_tags : 'name_tags Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp))));
- ([ Gram.Skeyword "[<";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (rfl : 'row_field) _ (_loc : Gram.Loc.t)
- -> (Ast.TyVrnInf (_loc, rfl) : 'ctyp))));
- ([ Gram.Skeyword "["; Gram.Skeyword "<";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t));
- Gram.Skeyword ">";
- Gram.Snterm
- (Gram.Entry.obj
- (name_tags : 'name_tags Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _
- _ (_loc : Gram.Loc.t) ->
- (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp))));
- ([ Gram.Skeyword "["; Gram.Skeyword "<";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (rfl : 'row_field) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.TyVrnInf (_loc, rfl) : 'ctyp))));
- ([ Gram.Skeyword "["; Gram.Skeyword ">";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (rfl : 'row_field) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.TyVrnSup (_loc, rfl) : 'ctyp))));
- ([ Gram.Skeyword "["; Gram.Skeyword ">";
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ _ _ (_loc : Gram.Loc.t) ->
- (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) :
- 'ctyp))));
- ([ Gram.Skeyword "["; Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (rfl : 'row_field) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.TyVrnEq (_loc, rfl) : 'ctyp))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_declarations :
- 'constructor_declarations Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (t : 'constructor_declarations) _
- (_loc : Gram.Loc.t) ->
- (Ast.TySum (_loc, t) : 'ctyp))));
- ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.TySum (_loc, (Ast.TyNil _loc)) : 'ctyp))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
- (t : 'ctyp))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword "*";
- Gram.Snterm
- (Gram.Entry.obj
- (star_ctyp : 'star_ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyTup (_loc, (Ast.TySta (_loc, t, tl))) :
- 'ctyp))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) :
- 'ctyp))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) :
- 'ctyp))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'ctyp)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("id", _) -> true
- | _ -> false),
- "ANTIQUOT (\"id\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("id" as n)), s) ->
- (Ast.TyId (_loc,
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)))) :
- 'ctyp)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("tup", _) -> true
- | _ -> false),
- "ANTIQUOT (\"tup\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("tup" as n)), s) ->
- (Ast.TyTup (_loc,
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)))) :
- 'ctyp)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
- ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'ctyp)
- | _ -> assert false)));
- ([ Gram.Skeyword "_" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.TyAny _loc : 'ctyp))));
- ([ Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ]))
- ());
- Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'star_ctyp))));
- ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TySta (_loc, t1, t2) : 'star_ctyp))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp*" n s)) :
- 'star_ctyp)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'star_ctyp)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (constructor_declarations :
- 'constructor_declarations Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) :
- 'constructor_declarations))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (s : 'a_UIDENT)
- (_loc : Gram.Loc.t) ->
- (let (tl, rt) = generalized_type_of_type t
- in
- Ast.TyCol (_loc,
- (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
- (Ast.TyArr (_loc,
- (Ast.tyAnd_of_list tl), rt))) :
- 'constructor_declarations))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "of";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_arg_list :
- 'constructor_arg_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'constructor_arg_list) _
- (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.TyOf (_loc,
- (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
- t) :
- 'constructor_declarations))));
- ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'constructor_declarations) _
- (t1 : 'constructor_declarations)
- (_loc : Gram.Loc.t) ->
- (Ast.TyOr (_loc, t1, t2) :
- 'constructor_declarations))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'constructor_declarations)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp|" n s)) :
- 'constructor_declarations)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'constructor_declarations)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (constructor_declaration :
- 'constructor_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) :
- 'constructor_declaration))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "of";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_arg_list :
- 'constructor_arg_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'constructor_arg_list) _
- (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.TyOf (_loc,
- (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
- t) :
- 'constructor_declaration))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'constructor_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'constructor_declaration)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'constructor_arg_list))));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'constructor_arg_list) _
- (t1 : 'constructor_arg_list)
- (_loc : Gram.Loc.t) ->
- (Ast.TyAnd (_loc, t1, t2) :
- 'constructor_arg_list))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctypand" n s)) :
- 'constructor_arg_list)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (label_declaration_list :
- 'label_declaration_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_declaration :
- 'label_declaration Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t1 : 'label_declaration)
- (_loc : Gram.Loc.t) ->
- (t1 : 'label_declaration_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_declaration :
- 'label_declaration Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (t1 : 'label_declaration)
- (_loc : Gram.Loc.t) ->
- (t1 : 'label_declaration_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_declaration :
- 'label_declaration Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'label_declaration_list) _
- (t1 : 'label_declaration) (_loc : Gram.Loc.t)
- ->
- (Ast.TySem (_loc, t1, t2) :
- 'label_declaration_list)))) ]) ]))
- ());
- Gram.extend
- (label_declaration : 'label_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":"; Gram.Skeyword "mutable";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ _ (s : 'a_LIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCol (_loc,
- (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))),
- (Ast.TyMut (_loc, t))) :
- 'label_declaration))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (s : 'a_LIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCol (_loc,
- (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))),
- t) :
- 'label_declaration))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'label_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp;" n s)) :
- 'label_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'label_declaration)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_ident : 'a_ident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (i : 'a_ident))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (i : 'a_ident)))) ]) ]))
- ());
- Gram.extend (ident : 'ident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'ident) _ (i : 'a_UIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) :
- 'ident))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)"));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (i : 'ident) _ (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAcc (_loc,
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s))),
- i) :
- 'ident)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdLid (_loc, i) : 'ident))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdUid (_loc, i) : 'ident))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'ident)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (module_longident : 'module_longident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdUid (_loc, i) : 'module_longident))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (l : 'module_longident) _ (m : 'a_UIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) :
- 'module_longident))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'module_longident)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (module_longident_with_app :
- 'module_longident_with_app Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "apply"), None,
- [ ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'module_longident_with_app)
- (i : 'module_longident_with_app)
- (_loc : Gram.Loc.t) ->
- (Ast.IdApp (_loc, i, j) :
- 'module_longident_with_app)))) ]);
- ((Some "."), None,
- [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'module_longident_with_app) _
- (i : 'module_longident_with_app)
- (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, i, j) :
- 'module_longident_with_app)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (i : 'module_longident_with_app) _
- (_loc : Gram.Loc.t) ->
- (i : 'module_longident_with_app))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdUid (_loc, i) :
- 'module_longident_with_app))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'module_longident_with_app)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (module_longident_dot_lparen :
- 'module_longident_dot_lparen Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "."; Gram.Skeyword "(" ],
- (Gram.Action.mk
- (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdUid (_loc, i) :
- 'module_longident_dot_lparen))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (l : 'module_longident_dot_lparen) _
- (m : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) :
- 'module_longident_dot_lparen))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)"));
- Gram.Skeyword "."; Gram.Skeyword "(" ],
- (Gram.Action.mk
- (fun _ _ (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'module_longident_dot_lparen)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (type_longident : 'type_longident Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "apply"), None,
- [ ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'type_longident) (i : 'type_longident)
- (_loc : Gram.Loc.t) ->
- (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]);
- ((Some "."), None,
- [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'type_longident) _
- (i : 'type_longident) (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (i : 'type_longident) _
- (_loc : Gram.Loc.t) -> (i : 'type_longident))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdUid (_loc, i) : 'type_longident))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdLid (_loc, i) : 'type_longident))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'type_longident)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (label_longident : 'label_longident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdLid (_loc, i) : 'label_longident))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (l : 'label_longident) _ (m : 'a_UIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) :
- 'label_longident))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'label_longident)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (class_type_longident : 'class_type_longident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (type_longident :
- 'type_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'type_longident) (_loc : Gram.Loc.t)
- -> (x : 'class_type_longident)))) ]) ]))
- ());
- Gram.extend (val_longident : 'val_longident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'ident) (_loc : Gram.Loc.t) ->
- (x : 'val_longident)))) ]) ]))
- ());
- Gram.extend (class_longident : 'class_longident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (label_longident :
- 'label_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'label_longident) (_loc : Gram.Loc.t)
- -> (x : 'class_longident)))) ]) ]))
- ());
- Gram.extend
- (class_declaration : 'class_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_info_for_class_expr :
- 'class_info_for_class_expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_fun_binding :
- 'class_fun_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ce : 'class_fun_binding)
- (ci : 'class_info_for_class_expr)
- (_loc : Gram.Loc.t) ->
- (Ast.CeEq (_loc, ci, ce) :
- 'class_declaration))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_expr_tag :
- 'class_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "cdcl" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "cdcl" | "anti" | "list" as n)),
- s) ->
- (Ast.CeAnt (_loc,
- (mk_anti ~c: "class_expr" n s)) :
- 'class_declaration)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (c2 : 'class_declaration) _
- (c1 : 'class_declaration) (_loc : Gram.Loc.t)
- ->
- (Ast.CeAnd (_loc, c1, c2) :
- 'class_declaration)))) ]) ]))
- ());
- Gram.extend
- (class_fun_binding : 'class_fun_binding Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (cfb : 'class_fun_binding)
- (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
- (Ast.CeFun (_loc, p, cfb) :
- 'class_fun_binding))));
- ([ Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type_plus :
- 'class_type_plus Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (class_expr : 'class_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ce : 'class_expr) _
- (ct : 'class_type_plus) _ (_loc : Gram.Loc.t)
- ->
- (Ast.CeTyc (_loc, ce, ct) :
- 'class_fun_binding))));
- ([ Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (class_expr : 'class_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) ->
- (ce : 'class_fun_binding)))) ]) ]))
- ());
- Gram.extend
- (class_info_for_class_type :
- 'class_info_for_class_type Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_virtual : 'opt_virtual Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_name_and_param :
- 'class_name_and_param Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((i, ot) : 'class_name_and_param)
- (mv : 'opt_virtual) (_loc : Gram.Loc.t) ->
- (Ast.CtCon (_loc, mv, (Ast.IdLid (_loc, i)),
- ot) :
- 'class_info_for_class_type)))) ]) ]))
- ());
- Gram.extend
- (class_info_for_class_expr :
- 'class_info_for_class_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_virtual : 'opt_virtual Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_name_and_param :
- 'class_name_and_param Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((i, ot) : 'class_name_and_param)
- (mv : 'opt_virtual) (_loc : Gram.Loc.t) ->
- (Ast.CeCon (_loc, mv, (Ast.IdLid (_loc, i)),
- ot) :
- 'class_info_for_class_expr)))) ]) ]))
- ());
- Gram.extend
- (class_name_and_param : 'class_name_and_param Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- ((i, (Ast.TyNil _loc)) :
- 'class_name_and_param))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_type_parameter :
- 'comma_type_parameter Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (x : 'comma_type_parameter) _
- (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- ((i, x) : 'class_name_and_param)))) ]) ]))
- ());
- Gram.extend
- (comma_type_parameter : 'comma_type_parameter Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (type_parameter :
- 'type_parameter Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'type_parameter) (_loc : Gram.Loc.t)
- -> (t : 'comma_type_parameter))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp," n s)) :
- 'comma_type_parameter)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'comma_type_parameter) _
- (t1 : 'comma_type_parameter)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCom (_loc, t1, t2) :
- 'comma_type_parameter)))) ]) ]))
- ());
- Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.TyNil _loc : 'opt_comma_ctyp))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_ctyp : 'comma_ctyp Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t)
- -> (x : 'opt_comma_ctyp)))) ]) ]))
- ());
- Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'comma_ctyp))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp," n s)) :
- 'comma_ctyp)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ]))
- ());
- Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "->";
- Gram.Snterm
- (Gram.Entry.obj
- (class_expr : 'class_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) ->
- (ce : 'class_fun_def))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (ce : 'class_fun_def) (p : 'labeled_ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ]))
- ());
- Gram.extend (class_expr : 'class_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "top"), None,
- [ ([ Gram.Skeyword "let";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (binding : 'binding Gram.Entry.t));
- Gram.Skeyword "in"; Gram.Sself ],
- (Gram.Action.mk
- (fun (ce : 'class_expr) _ (bi : 'binding)
- (rf : 'opt_rec) _ (_loc : Gram.Loc.t) ->
- (Ast.CeLet (_loc, rf, bi, ce) : 'class_expr))));
- ([ Gram.Skeyword "fun";
- Gram.Snterm
- (Gram.Entry.obj
- (labeled_ipatt :
- 'labeled_ipatt Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_fun_def :
- 'class_fun_def Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ce : 'class_fun_def) (p : 'labeled_ipatt)
- _ (_loc : Gram.Loc.t) ->
- (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]);
- ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA),
- [ ([ Gram.Sself;
- Gram.Snterml
- ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
- "label") ],
- (Gram.Action.mk
- (fun (e : 'expr) (ce : 'class_expr)
- (_loc : Gram.Loc.t) ->
- (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (ce : 'class_expr) _ (_loc : Gram.Loc.t)
- -> (ce : 'class_expr))));
- ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type : 'class_type Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (ct : 'class_type) _ (ce : 'class_expr) _
- (_loc : Gram.Loc.t) ->
- (Ast.CeTyc (_loc, ce, ct) : 'class_expr))));
- ([ Gram.Skeyword "object";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_class_self_patt :
- 'opt_class_self_patt Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_structure :
- 'class_structure Gram.Entry.t));
- Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ (cst : 'class_structure)
- (csp : 'opt_class_self_patt) _
- (_loc : Gram.Loc.t) ->
- (Ast.CeStr (_loc, csp, cst) : 'class_expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_longident_and_param :
- 'class_longident_and_param Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ce : 'class_longident_and_param)
- (_loc : Gram.Loc.t) -> (ce : 'class_expr))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_expr_tag :
- 'class_expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "cexp" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "cexp" | "anti" as n)), s)
- ->
- (Ast.CeAnt (_loc,
- (mk_anti ~c: "class_expr" n s)) :
- 'class_expr)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (class_longident_and_param :
- 'class_longident_and_param Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_longident :
- 'class_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ci : 'class_longident) (_loc : Gram.Loc.t)
- ->
- (Ast.CeCon (_loc, Ast.ViNil, ci,
- (Ast.TyNil _loc)) :
- 'class_longident_and_param))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_longident :
- 'class_longident Gram.Entry.t));
- Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_ctyp : 'comma_ctyp Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (t : 'comma_ctyp) _
- (ci : 'class_longident) (_loc : Gram.Loc.t)
- ->
- (Ast.CeCon (_loc, Ast.ViNil, ci, t) :
- 'class_longident_and_param)))) ]) ]))
- ());
- Gram.extend (class_structure : 'class_structure Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Slist0
- (Gram.srules class_structure
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_str_item :
- 'class_str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (cst : 'class_str_item)
- (_loc : Gram.Loc.t) ->
- (cst : 'e__10)))) ]) ],
- (Gram.Action.mk
- (fun (l : 'e__10 list) (_loc : Gram.Loc.t) ->
- (Ast.crSem_of_list l : 'class_structure))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "cst" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)"));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (cst : 'class_structure) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "cst" | "anti" | "list" as n)),
- s) ->
- (Ast.CrSem (_loc,
- (Ast.CrAnt (_loc,
- (mk_anti ~c: "class_str_item" n s))),
- cst) :
- 'class_structure)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "cst" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "cst" | "anti" | "list" as n)),
- s) ->
- (Ast.CrAnt (_loc,
- (mk_anti ~c: "class_str_item" n s)) :
- 'class_structure)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.PaNil _loc : 'opt_class_self_patt))));
- ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (p : 'patt) _
- (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, p, t) :
- 'opt_class_self_patt))));
- ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
- (p : 'opt_class_self_patt)))) ]) ]))
- ());
- Gram.extend (class_str_item : 'class_str_item Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Skeyword "initializer";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (se : 'expr) _ (_loc : Gram.Loc.t) ->
- (Ast.CrIni (_loc, se) : 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (type_constraint :
- 'type_constraint Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (_loc : Gram.Loc.t) ->
- (Ast.CrCtr (_loc, t1, t2) : 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (method_opt_override :
- 'method_opt_override Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t));
- Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label) _
- (pf : 'opt_private)
- (o : 'method_opt_override)
- (_loc : Gram.Loc.t) ->
- (if o <> Ast.OvNil
- then
- raise
- (Stream.Error
- "override (!) is incompatible with virtual")
- else Ast.CrVir (_loc, l, pf, t) :
- 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (method_opt_override :
- 'method_opt_override Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_polyt : 'opt_polyt Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (fun_binding : 'fun_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'fun_binding) (topt : 'opt_polyt)
- (l : 'label) (pf : 'opt_private)
- (o : 'method_opt_override)
- (_loc : Gram.Loc.t) ->
- (Ast.CrMth (_loc, l, o, pf, e, topt) :
- 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (method_opt_override :
- 'method_opt_override Gram.Entry.t));
- Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label)
- (pf : 'opt_private) _
- (o : 'method_opt_override)
- (_loc : Gram.Loc.t) ->
- (if o <> Ast.OvNil
- then
- raise
- (Stream.Error
- "override (!) is incompatible with virtual")
- else Ast.CrVir (_loc, l, pf, t) :
- 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val_opt_override :
- 'value_val_opt_override Gram.Entry.t));
- Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_mutable : 'opt_mutable Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label)
- (mf : 'opt_mutable) _
- (o : 'value_val_opt_override)
- (_loc : Gram.Loc.t) ->
- (if o <> Ast.OvNil
- then
- raise
- (Stream.Error
- "override (!) is incompatible with virtual")
- else Ast.CrVvr (_loc, l, mf, t) :
- 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val_opt_override :
- 'value_val_opt_override Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_mutable : 'opt_mutable Gram.Entry.t));
- Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label) _
- (mf : 'opt_mutable)
- (o : 'value_val_opt_override)
- (_loc : Gram.Loc.t) ->
- (if o <> Ast.OvNil
- then
- raise
- (Stream.Error
- "override (!) is incompatible with virtual")
- else Ast.CrVvr (_loc, l, mf, t) :
- 'class_str_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val_opt_override :
- 'value_val_opt_override Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_mutable : 'opt_mutable Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (cvalue_binding :
- 'cvalue_binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'cvalue_binding) (lab : 'label)
- (mf : 'opt_mutable)
- (o : 'value_val_opt_override)
- (_loc : Gram.Loc.t) ->
- (Ast.CrVal (_loc, lab, o, mf, e) :
- 'class_str_item))));
- ([ Gram.Skeyword "inherit";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_override : 'opt_override Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_expr : 'class_expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_as_lident :
- 'opt_as_lident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (pb : 'opt_as_lident) (ce : 'class_expr)
- (o : 'opt_override) _ (_loc : Gram.Loc.t) ->
- (Ast.CrInh (_loc, o, ce, pb) :
- 'class_str_item))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_str_item_tag :
- 'class_str_item)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "cst" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "cst" | "anti" | "list" as n)),
- s) ->
- (Ast.CrAnt (_loc,
- (mk_anti ~c: "class_str_item" n s)) :
- 'class_str_item)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (method_opt_override : 'method_opt_override Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "method" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.OvNil : 'method_opt_override))));
- ([ Gram.Skeyword "method";
- Gram.Stoken
- (((function
- | ANTIQUOT (("!" | "override" | "anti"), _)
- -> true
- | _ -> false),
- "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("!" | "override" | "anti" as n)), s)
- ->
- (Ast.OvAnt (mk_anti n s) :
- 'method_opt_override)
- | _ -> assert false)));
- ([ Gram.Skeyword "method"; Gram.Skeyword "!" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.OvOverride : 'method_opt_override)))) ]) ]))
- ());
- Gram.extend
- (value_val_opt_override :
- 'value_val_opt_override Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.OvNil : 'value_val_opt_override))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t));
- Gram.Stoken
- (((function
- | ANTIQUOT (("!" | "override" | "anti"), _)
- -> true
- | _ -> false),
- "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("!" | "override" | "anti" as n)), s)
- ->
- (Ast.OvAnt (mk_anti n s) :
- 'value_val_opt_override)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t));
- Gram.Skeyword "!" ],
- (Gram.Action.mk
- (fun _ _ (_loc : Gram.Loc.t) ->
- (Ast.OvOverride : 'value_val_opt_override)))) ]) ]))
- ());
- Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- ("" : 'opt_as_lident))));
- ([ Gram.Skeyword "as";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
- (i : 'opt_as_lident)))) ]) ]))
- ());
- Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.TyNil _loc : 'opt_polyt))));
- ([ Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) ->
- (t : 'opt_polyt)))) ]) ]))
- ());
- Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword ":>";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (t : 'ctyp) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) :
- 'cvalue_binding))));
- ([ Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t));
- Gram.Skeyword ":>";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (t2 : 'ctyp) _
- (t : 'poly_type) _ (_loc : Gram.Loc.t) ->
- (match t with
- | Ast.TyPol (_, _, _) ->
- raise
- (Stream.Error
- "unexpected polytype here")
- | _ -> Ast.ExCoe (_loc, e, t, t2) :
- 'cvalue_binding))));
- ([ Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (t : 'poly_type) _
- (_loc : Gram.Loc.t) ->
- (Ast.ExTyc (_loc, e, t) : 'cvalue_binding))));
- ([ Gram.Skeyword ":"; Gram.Skeyword "type";
- Gram.Snterm
- (Gram.Entry.obj
- (unquoted_typevars :
- 'unquoted_typevars Gram.Entry.t));
- Gram.Skeyword ".";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (t2 : 'ctyp) _
- (t1 : 'unquoted_typevars) _ _
- (_loc : Gram.Loc.t) ->
- (let u = Ast.TyTypePol (_loc, t1, t2)
- in Ast.ExTyc (_loc, e, u) : 'cvalue_binding))));
- ([ Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (e : 'cvalue_binding)))) ]) ]))
- ());
- Gram.extend (label : 'label Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (i : 'label)))) ]) ]))
- ());
- Gram.extend (class_type : 'class_type Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "object";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_class_self_type :
- 'opt_class_self_type Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (class_signature :
- 'class_signature Gram.Entry.t));
- Gram.Skeyword "end" ],
- (Gram.Action.mk
- (fun _ (csg : 'class_signature)
- (cst : 'opt_class_self_type) _
- (_loc : Gram.Loc.t) ->
- (Ast.CtSig (_loc, cst, csg) : 'class_type))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_type_longident_and_param :
- 'class_type_longident_and_param Gram.
- Entry.t)) ],
- (Gram.Action.mk
- (fun (ct : 'class_type_longident_and_param)
- (_loc : Gram.Loc.t) -> (ct : 'class_type))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_type_tag :
- 'class_type)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "ctyp" | "anti"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "ctyp" | "anti" as n)), s)
- ->
- (Ast.CtAnt (_loc,
- (mk_anti ~c: "class_type" n s)) :
- 'class_type)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend
- (class_type_longident_and_param :
- 'class_type_longident_and_param Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_type_longident :
- 'class_type_longident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'class_type_longident)
- (_loc : Gram.Loc.t) ->
- (Ast.CtCon (_loc, Ast.ViNil, i,
- (Ast.TyNil _loc)) :
- 'class_type_longident_and_param))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_type_longident :
- 'class_type_longident Gram.Entry.t));
- Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_ctyp : 'comma_ctyp Gram.Entry.t));
- Gram.Skeyword "]" ],
- (Gram.Action.mk
- (fun _ (t : 'comma_ctyp) _
- (i : 'class_type_longident)
- (_loc : Gram.Loc.t) ->
- (Ast.CtCon (_loc, Ast.ViNil, i, t) :
- 'class_type_longident_and_param)))) ]) ]))
- ());
- Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_type : 'class_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ct : 'class_type) (_loc : Gram.Loc.t) ->
- (ct : 'class_type_plus))));
- ([ Gram.Skeyword "[";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "]"; Gram.Skeyword "->"; Gram.Sself ],
- (Gram.Action.mk
- (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _
- (_loc : Gram.Loc.t) ->
- (Ast.CtFun (_loc, t, ct) : 'class_type_plus)))) ]) ]))
- ());
- Gram.extend
- (opt_class_self_type : 'opt_class_self_type Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.TyNil _loc : 'opt_class_self_type))));
- ([ Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
- (t : 'opt_class_self_type)))) ]) ]))
- ());
- Gram.extend (class_signature : 'class_signature Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Slist0
- (Gram.srules class_signature
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_sig_item :
- 'class_sig_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (csg : 'class_sig_item)
- (_loc : Gram.Loc.t) ->
- (csg : 'e__11)))) ]) ],
- (Gram.Action.mk
- (fun (l : 'e__11 list) (_loc : Gram.Loc.t) ->
- (Ast.cgSem_of_list l : 'class_signature))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "csg" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)"));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (csg : 'class_signature) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "csg" | "anti" | "list" as n)),
- s) ->
- (Ast.CgSem (_loc,
- (Ast.CgAnt (_loc,
- (mk_anti ~c: "class_sig_item" n s))),
- csg) :
- 'class_signature)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "csg" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "csg" | "anti" | "list" as n)),
- s) ->
- (Ast.CgAnt (_loc,
- (mk_anti ~c: "class_sig_item" n s)) :
- 'class_signature)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (type_constraint :
- 'type_constraint Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (_loc : Gram.Loc.t) ->
- (Ast.CgCtr (_loc, t1, t2) : 'class_sig_item))));
- ([ Gram.Skeyword "method";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t));
- Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label) _
- (pf : 'opt_private) _ (_loc : Gram.Loc.t) ->
- (Ast.CgVir (_loc, l, pf, t) :
- 'class_sig_item))));
- ([ Gram.Skeyword "method";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label)
- (pf : 'opt_private) _ (_loc : Gram.Loc.t) ->
- (Ast.CgMth (_loc, l, pf, t) :
- 'class_sig_item))));
- ([ Gram.Skeyword "method"; Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (l : 'label)
- (pf : 'opt_private) _ _ (_loc : Gram.Loc.t)
- ->
- (Ast.CgVir (_loc, l, pf, t) :
- 'class_sig_item))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (value_val : 'value_val Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_mutable : 'opt_mutable Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_virtual : 'opt_virtual Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (l : 'label)
- (mv : 'opt_virtual) (mf : 'opt_mutable) _
- (_loc : Gram.Loc.t) ->
- (Ast.CgVal (_loc, l, mf, mv, t) :
- 'class_sig_item))));
- ([ Gram.Skeyword "inherit";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type : 'class_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (cs : 'class_type) _ (_loc : Gram.Loc.t) ->
- (Ast.CgInh (_loc, cs) : 'class_sig_item))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_sig_item_tag :
- 'class_sig_item)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "csg" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "csg" | "anti" | "list" as n)),
- s) ->
- (Ast.CgAnt (_loc,
- (mk_anti ~c: "class_sig_item" n s)) :
- 'class_sig_item)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (type_constraint : 'type_constraint Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "constraint" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (() : 'type_constraint))));
- ([ Gram.Skeyword "type" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (() : 'type_constraint)))) ]) ]))
- ());
- Gram.extend
- (class_description : 'class_description Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_info_for_class_type :
- 'class_info_for_class_type Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type_plus :
- 'class_type_plus Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ct : 'class_type_plus) _
- (ci : 'class_info_for_class_type)
- (_loc : Gram.Loc.t) ->
- (Ast.CtCol (_loc, ci, ct) :
- 'class_description))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_type_tag :
- 'class_description)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "typ" | "anti" | "list" as n)),
- s) ->
- (Ast.CtAnt (_loc,
- (mk_anti ~c: "class_type" n s)) :
- 'class_description)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (cd2 : 'class_description) _
- (cd1 : 'class_description)
- (_loc : Gram.Loc.t) ->
- (Ast.CtAnd (_loc, cd1, cd2) :
- 'class_description)))) ]) ]))
- ());
- Gram.extend
- (class_type_declaration :
- 'class_type_declaration Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (class_info_for_class_type :
- 'class_info_for_class_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (class_type : 'class_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ct : 'class_type) _
- (ci : 'class_info_for_class_type)
- (_loc : Gram.Loc.t) ->
- (Ast.CtEq (_loc, ci, ct) :
- 'class_type_declaration))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.class_type_tag :
- 'class_type_declaration)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "typ" | "anti" | "list" as n)),
- s) ->
- (Ast.CtAnt (_loc,
- (mk_anti ~c: "class_type" n s)) :
- 'class_type_declaration)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (cd2 : 'class_type_declaration) _
- (cd1 : 'class_type_declaration)
- (_loc : Gram.Loc.t) ->
- (Ast.CtAnd (_loc, cd1, cd2) :
- 'class_type_declaration)))) ]) ]))
- ());
- Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (field_expr : 'field_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) ->
- (b1 : 'field_expr_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (field_expr : 'field_expr Gram.Entry.t));
- Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) ->
- (b1 : 'field_expr_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (field_expr : 'field_expr Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun (b2 : 'field_expr_list) _
- (b1 : 'field_expr) (_loc : Gram.Loc.t) ->
- (Ast.RbSem (_loc, b1, b2) : 'field_expr_list)))) ]) ]))
- ());
- Gram.extend (field_expr : 'field_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (label : 'label Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterml
- ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
- "top") ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (l : 'label)
- (_loc : Gram.Loc.t) ->
- (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) :
- 'field_expr))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.RbAnt (_loc,
- (mk_anti ~c: "rec_binding" n s)) :
- 'field_expr)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "bi" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "bi" | "anti" as n)), s)
- ->
- (Ast.RbAnt (_loc,
- (mk_anti ~c: "rec_binding" n s)) :
- 'field_expr)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (meth_list : 'meth_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (meth_decl : 'meth_decl Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (v : 'opt_dot_dot) (m : 'meth_decl)
- (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (meth_decl : 'meth_decl Gram.Entry.t));
- Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (v : 'opt_dot_dot) _ (m : 'meth_decl)
- (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (meth_decl : 'meth_decl Gram.Entry.t));
- Gram.Skeyword ";"; Gram.Sself ],
- (Gram.Action.mk
- (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl)
- (_loc : Gram.Loc.t) ->
- (((Ast.TySem (_loc, m, ml)), v) : 'meth_list)))) ]) ]))
- ());
- Gram.extend (meth_decl : 'meth_decl Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (poly_type : 'poly_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'poly_type) _ (lab : 'a_LIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCol (_loc,
- (Ast.TyId (_loc, (Ast.IdLid (_loc, lab)))),
- t) :
- 'meth_decl))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'meth_decl)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp;" n s)) :
- 'meth_decl)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'meth_decl)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) ->
- (Ast.TyObj (_loc, (Ast.TyNil _loc), v) :
- 'opt_meth_list))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (meth_list : 'meth_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((ml, v) : 'meth_list) (_loc : Gram.Loc.t)
- -> (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ]))
- ());
- Gram.extend (poly_type : 'poly_type Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'poly_type)))) ]) ]))
- ());
- Gram.extend (package_type : 'package_type Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'module_type) (_loc : Gram.Loc.t) ->
- (p : 'package_type)))) ]) ]))
- ());
- Gram.extend (typevars : 'typevars Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Skeyword "'";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyQuo (_loc, i) : 'typevars))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'typevars)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'typevars)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'typevars) (t1 : 'typevars)
- (_loc : Gram.Loc.t) ->
- (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ]))
- ());
- Gram.extend
- (unquoted_typevars : 'unquoted_typevars Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, (Some Camlp4.Sig.Grammar.LeftA),
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) (_loc : Gram.Loc.t) ->
- (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) :
- 'unquoted_typevars))));
- ([ Gram.Stoken
- (((function | QUOTATION _ -> true | _ -> false),
- "QUOTATION _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | QUOTATION x ->
- (Quotation.expand _loc x Quotation.
- DynAst.ctyp_tag :
- 'unquoted_typevars)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'unquoted_typevars)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'unquoted_typevars)
- (t1 : 'unquoted_typevars) (_loc : Gram.Loc.t)
- ->
- (Ast.TyApp (_loc, t1, t2) :
- 'unquoted_typevars)))) ]) ]))
- ());
- Gram.extend (row_field : 'row_field Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'row_field))));
- ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t));
- Gram.Skeyword "of";
- Gram.Snterm
- (Gram.Entry.obj
- (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'amp_ctyp) _ (i : 'a_ident) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) :
- 'row_field))));
- ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t));
- Gram.Skeyword "of"; Gram.Skeyword "&";
- Gram.Snterm
- (Gram.Entry.obj
- (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _
- (_loc : Gram.Loc.t) ->
- (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)), t) :
- 'row_field))));
- ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyVrn (_loc, i) : 'row_field))));
- ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'row_field) _ (t1 : 'row_field)
- (_loc : Gram.Loc.t) ->
- (Ast.TyOr (_loc, t1, t2) : 'row_field))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp|" n s)) :
- 'row_field)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'row_field)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
- (t : 'amp_ctyp))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("list", _) -> true
- | _ -> false),
- "ANTIQUOT (\"list\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("list" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp&" n s)) :
- 'amp_ctyp)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ]))
- ());
- Gram.extend (name_tags : 'name_tags Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyVrn (_loc, i) : 'name_tags))));
- ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (t2 : 'name_tags) (t1 : 'name_tags)
- (_loc : Gram.Loc.t) ->
- (Ast.TyApp (_loc, t1, t2) : 'name_tags))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "typ"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "typ" as n)), s) ->
- (Ast.TyAnt (_loc,
- (mk_anti ~c: "ctyp" n s)) :
- 'name_tags)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (eq_expr : 'eq_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (fun i p -> Ast.PaOlb (_loc, i, p) :
- 'eq_expr))));
- ([ Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
- (fun i p -> Ast.PaOlbi (_loc, i, p, e) :
- 'eq_expr)))) ]) ]))
- ());
- Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'patt) (_loc : Gram.Loc.t) ->
- (p : 'patt_tcon))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (p : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ]))
- ());
- Gram.extend (ipatt : 'ipatt Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "?"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _
- (_loc : Gram.Loc.t) ->
- (Ast.PaOlbi (_loc, "", p, e) : 'ipatt))));
- ([ Gram.Skeyword "?"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (p : 'ipatt_tcon) _ _ (_loc : Gram.Loc.t)
- -> (Ast.PaOlb (_loc, "", p) : 'ipatt))));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (Ast.PaOlb (_loc, (mk_anti n i),
- (Ast.PaNil _loc)) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function | LIDENT _ -> true | _ -> false),
- "LIDENT _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LIDENT i ->
- (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)"));
- Gram.Skeyword ":"; Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (eq_expr : 'eq_expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _
- (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (f (mk_anti n i) p : 'ipatt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | OPTLABEL _ -> true | _ -> false),
- "OPTLABEL _"));
- Gram.Skeyword "(";
- Gram.Snterm
- (Gram.Entry.obj
- (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (eq_expr : 'eq_expr Gram.Entry.t));
- Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | OPTLABEL i -> (f i p : 'ipatt)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function | LIDENT _ -> true | _ -> false),
- "LIDENT _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LIDENT i ->
- (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (Ast.PaLab (_loc, (mk_anti n i),
- (Ast.PaNil _loc)) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)"));
- Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (p : 'ipatt) _ (__camlp4_0 : Gram.Token.t)
- _ (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), i) ->
- (Ast.PaLab (_loc, (mk_anti n i), p) :
- 'ipatt)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function | LABEL _ -> true | _ -> false),
- "LABEL _"));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LABEL i ->
- (Ast.PaLab (_loc, i, p) : 'ipatt)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (p : 'ipatt) (_loc : Gram.Loc.t) ->
- (p : 'ipatt_tcon))));
- ([ Gram.Snterm
- (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (t : 'ctyp) _ (p : 'ipatt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ]))
- ());
- Gram.extend (direction_flag : 'direction_flag Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function
- | ANTIQUOT (("to" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"to\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("to" | "anti" as n)), s) ->
- (Ast.DiAnt (mk_anti n s) :
- 'direction_flag)
- | _ -> assert false)));
- ([ Gram.Skeyword "downto" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.DiDownto : 'direction_flag))));
- ([ Gram.Skeyword "to" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.DiTo : 'direction_flag)))) ]) ]))
- ());
- Gram.extend (opt_private : 'opt_private Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.PrNil : 'opt_private))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("private" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"private\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("private" | "anti" as n)), s)
- ->
- (Ast.PrAnt (mk_anti n s) : 'opt_private)
- | _ -> assert false)));
- ([ Gram.Skeyword "private" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.PrPrivate : 'opt_private)))) ]) ]))
- ());
- Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.MuNil : 'opt_mutable))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("mutable" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("mutable" | "anti" as n)), s)
- ->
- (Ast.MuAnt (mk_anti n s) : 'opt_mutable)
- | _ -> assert false)));
- ([ Gram.Skeyword "mutable" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.MuMutable : 'opt_mutable)))) ]) ]))
- ());
- Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.ViNil : 'opt_virtual))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("virtual" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("virtual" | "anti" as n)), s)
- ->
- (Ast.ViAnt (mk_anti n s) : 'opt_virtual)
- | _ -> assert false)));
- ([ Gram.Skeyword "virtual" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.ViVirtual : 'opt_virtual)))) ]) ]))
- ());
- Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.RvNil : 'opt_dot_dot))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ((".." | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"..\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT (((".." | "anti" as n)), s) ->
- (Ast.RvAnt (mk_anti n s) : 'opt_dot_dot)
- | _ -> assert false)));
- ([ Gram.Skeyword ".." ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.RvRowVar : 'opt_dot_dot)))) ]) ]))
- ());
- Gram.extend (opt_rec : 'opt_rec Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.ReNil : 'opt_rec))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("rec" | "anti"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("rec" | "anti" as n)), s) ->
- (Ast.ReAnt (mk_anti n s) : 'opt_rec)
- | _ -> assert false)));
- ([ Gram.Skeyword "rec" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.ReRecursive : 'opt_rec)))) ]) ]))
- ());
- Gram.extend (opt_override : 'opt_override Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.OvNil : 'opt_override))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("!" | "override" | "anti"), _)
- -> true
- | _ -> false),
- "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("!" | "override" | "anti" as n)), s)
- ->
- (Ast.OvAnt (mk_anti n s) : 'opt_override)
- | _ -> assert false)));
- ([ Gram.Skeyword "!" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) ->
- (Ast.OvOverride : 'opt_override)))) ]) ]))
- ());
- Gram.extend (opt_expr : 'opt_expr Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.ExNil _loc : 'opt_expr))));
- ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) (_loc : Gram.Loc.t) ->
- (e : 'opt_expr)))) ]) ]))
- ());
- Gram.extend (interf : 'interf Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | EOI -> true | _ -> false), "EOI")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | EOI -> (([], None) : 'interf)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (sig_item : 'sig_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun ((sil, stopped) : 'interf) _
- (si : 'sig_item) (_loc : Gram.Loc.t) ->
- (((si :: sil), stopped) : 'interf))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_expr : 'opt_expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (([ Ast.SgDir (_loc, n, dp) ],
- (stopped_at _loc)) : 'interf)))) ]) ]))
- ());
- Gram.extend (sig_items : 'sig_items Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Slist0
- (Gram.srules sig_items
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (sig_item :
- 'sig_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (sg : 'sig_item)
- (_loc : Gram.Loc.t) ->
- (sg : 'e__12)))) ]) ],
- (Gram.Action.mk
- (fun (l : 'e__12 list) (_loc : Gram.Loc.t) ->
- (Ast.sgSem_of_list l : 'sig_items))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "sigi" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)"));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (sg : 'sig_items) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "sigi" | "anti" | "list" as n)),
- s) ->
- (Ast.SgSem (_loc,
- (Ast.SgAnt (_loc,
- (mk_anti n ~c: "sig_item" s))),
- sg) :
- 'sig_items)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "sigi" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "sigi" | "anti" | "list" as n)),
- s) ->
- (Ast.SgAnt (_loc,
- (mk_anti n ~c: "sig_item" s)) :
- 'sig_items)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (implem : 'implem Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | EOI -> true | _ -> false), "EOI")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | EOI -> (([], None) : 'implem)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (str_item : 'str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun ((sil, stopped) : 'implem) _
- (si : 'str_item) (_loc : Gram.Loc.t) ->
- (((si :: sil), stopped) : 'implem))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_expr : 'opt_expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (([ Ast.StDir (_loc, n, dp) ],
- (stopped_at _loc)) : 'implem)))) ]) ]))
- ());
- Gram.extend (str_items : 'str_items Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Slist0
- (Gram.srules str_items
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (str_item :
- 'str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (st : 'str_item)
- (_loc : Gram.Loc.t) ->
- (st : 'e__13)))) ]) ],
- (Gram.Action.mk
- (fun (l : 'e__13 list) (_loc : Gram.Loc.t) ->
- (Ast.stSem_of_list l : 'str_items))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "stri" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)"));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (st : 'str_items) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "stri" | "anti" | "list" as n)),
- s) ->
- (Ast.StSem (_loc,
- (Ast.StAnt (_loc,
- (mk_anti n ~c: "str_item" s))),
- st) :
- 'str_items)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "stri" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "stri" | "anti" | "list" as n)),
- s) ->
- (Ast.StAnt (_loc,
- (mk_anti n ~c: "str_item" s)) :
- 'str_items)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (top_phrase : 'top_phrase Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | EOI -> true | _ -> false), "EOI")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | EOI -> (None : 'top_phrase)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj (phrase : 'phrase Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ph : 'phrase) (_loc : Gram.Loc.t) ->
- (Some ph : 'top_phrase)))) ]) ]))
- ());
- Gram.extend (use_file : 'use_file Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | EOI -> true | _ -> false), "EOI")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | EOI -> (([], None) : 'use_file)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (str_item : 'str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun ((sil, stopped) : 'use_file) _
- (si : 'str_item) (_loc : Gram.Loc.t) ->
- (((si :: sil), stopped) : 'use_file))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_expr : 'opt_expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (([ Ast.StDir (_loc, n, dp) ],
- (stopped_at _loc)) : 'use_file)))) ]) ]))
- ());
- Gram.extend (phrase : 'phrase Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (str_item : 'str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (st : 'str_item) (_loc : Gram.Loc.t) ->
- (st : 'phrase))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_expr : 'opt_expr Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ]))
- ());
- Gram.extend (a_INT : 'a_INT Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | INT (_, _) -> true | _ -> false),
- "INT (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | INT (_, s) -> (s : 'a_INT)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "int" | "`int"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "int" | "`int" as n)), s)
- -> (mk_anti n s : 'a_INT)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | INT32 (_, _) -> true | _ -> false),
- "INT32 (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | INT32 (_, s) -> (s : 'a_INT32)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "int32" | "`int32"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "int32" | "`int32" as n)),
- s) -> (mk_anti n s : 'a_INT32)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | INT64 (_, _) -> true | _ -> false),
- "INT64 (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | INT64 (_, s) -> (s : 'a_INT64)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "int64" | "`int64"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "int64" | "`int64" as n)),
- s) -> (mk_anti n s : 'a_INT64)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function
- | NATIVEINT (_, _) -> true
- | _ -> false),
- "NATIVEINT (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | NATIVEINT (_, s) -> (s : 'a_NATIVEINT)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT
- (("" | "nativeint" | "`nativeint"), _)
- -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "nativeint" | "`nativeint" as n)),
- s) -> (mk_anti n s : 'a_NATIVEINT)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | FLOAT (_, _) -> true | _ -> false),
- "FLOAT (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | FLOAT (_, s) -> (s : 'a_FLOAT)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "flo" | "`flo"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "flo" | "`flo" as n)), s)
- -> (mk_anti n s : 'a_FLOAT)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | CHAR (_, _) -> true | _ -> false),
- "CHAR (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | CHAR (_, s) -> (s : 'a_CHAR)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "chr" | "`chr"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "chr" | "`chr" as n)), s)
- -> (mk_anti n s : 'a_CHAR)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | UIDENT _ -> true | _ -> false),
- "UIDENT _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | UIDENT s -> (s : 'a_UIDENT)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "uid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"uid\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "uid" as n)), s) ->
- (mk_anti n s : 'a_UIDENT)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | LIDENT _ -> true | _ -> false),
- "LIDENT _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LIDENT s -> (s : 'a_LIDENT)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "lid"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "lid" as n)), s) ->
- (mk_anti n s : 'a_LIDENT)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | LABEL _ -> true | _ -> false),
- "LABEL _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | LABEL s -> (s : 'a_LABEL)
- | _ -> assert false)));
- ([ Gram.Skeyword "~";
- Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)"));
- Gram.Skeyword ":" ],
- (Gram.Action.mk
- (fun _ (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), s) ->
- (mk_anti n s : 'a_LABEL)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function | OPTLABEL _ -> true | _ -> false),
- "OPTLABEL _")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | OPTLABEL s -> (s : 'a_OPTLABEL)
- | _ -> assert false)));
- ([ Gram.Skeyword "?";
- Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)"));
- Gram.Skeyword ":" ],
- (Gram.Action.mk
- (fun _ (__camlp4_0 : Gram.Token.t) _
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), s) ->
- (mk_anti n s : 'a_OPTLABEL)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (a_STRING : 'a_STRING Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function
- | STRING (_, _) -> true
- | _ -> false),
- "STRING (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | STRING (_, s) -> (s : 'a_STRING)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "str" | "`str"), _) ->
- true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" | "str" | "`str" as n)), s)
- -> (mk_anti n s : 'a_STRING)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (string_list : 'string_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Stoken
- (((function
- | STRING (_, _) -> true
- | _ -> false),
- "STRING (_, _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | STRING (_, x) ->
- (Ast.LCons (x, Ast.LNil) : 'string_list)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | STRING (_, _) -> true
- | _ -> false),
- "STRING (_, _)"));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (xs : 'string_list)
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | STRING (_, x) ->
- (Ast.LCons (x, xs) : 'string_list)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "str_list"), _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"str_list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT (("" | "str_list"), s) ->
- (Ast.LAnt (mk_anti "str_list" s) :
- 'string_list)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (value_let : 'value_let Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "value" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) -> (() : 'value_let)))) ]) ]))
- ());
- Gram.extend (value_val : 'value_val Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword "value" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) -> (() : 'value_val)))) ]) ]))
- ());
- Gram.extend (semi : 'semi Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Skeyword ";" ],
- (Gram.Action.mk
- (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ]))
- ());
- Gram.extend (expr_quot : 'expr_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.ExNil _loc : 'expr_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e : 'expr) (_loc : Gram.Loc.t) ->
- (e : 'expr_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_expr : 'sem_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e2 : 'sem_expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExSem (_loc, e1, e2) : 'expr_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword ",";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_expr : 'comma_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (e2 : 'comma_expr) _ (e1 : 'expr)
- (_loc : Gram.Loc.t) ->
- (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ]))
- ());
- Gram.extend (patt_quot : 'patt_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.PaNil _loc : 'patt_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'patt) (_loc : Gram.Loc.t) ->
- (x : 'patt_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'patt) _ (x : 'patt)
- (_loc : Gram.Loc.t) ->
- (let i =
- match x with
- | Ast.PaAnt (loc, s) -> Ast.IdAnt (loc, s)
- | p -> Ast.ident_of_patt p
- in Ast.PaEq (_loc, i, y) : 'patt_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (sem_patt : 'sem_patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'sem_patt) _ (x : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaSem (_loc, x, y) : 'patt_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Skeyword ",";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_patt : 'comma_patt Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'comma_patt) _ (x : 'patt)
- (_loc : Gram.Loc.t) ->
- (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ]))
- ());
- Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.TyNil _loc : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (x : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "and";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_arg_list :
- 'constructor_arg_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'constructor_arg_list) _
- (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (Ast.TyAnd (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "&";
- Gram.Snterm
- (Gram.Entry.obj
- (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'amp_ctyp) _ (x : 'more_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyAmp (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "*";
- Gram.Snterm
- (Gram.Entry.obj
- (star_ctyp : 'star_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'star_ctyp) _ (x : 'more_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TySta (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (label_declaration_list :
- 'label_declaration_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (z : 'label_declaration_list) _
- (y : 'more_ctyp) _ (x : 'more_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)),
- z) :
- 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'more_ctyp) _ (x : 'more_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCol (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "of"; Gram.Skeyword "&";
- Gram.Snterm
- (Gram.Entry.obj
- (amp_ctyp : 'amp_ctyp Gram.Entry.t));
- Gram.Skeyword "|";
- Gram.Snterm
- (Gram.Entry.obj
- (row_field : 'row_field Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _
- (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (Ast.TyOr (_loc, (Ast.TyOfAmp (_loc, x, y)),
- z) :
- 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "of"; Gram.Skeyword "&";
- Gram.Snterm
- (Gram.Entry.obj
- (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "of";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_arg_list :
- 'constructor_arg_list Gram.Entry.t));
- Gram.Skeyword "|";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_declarations :
- 'constructor_declarations Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (z : 'constructor_declarations) _
- (y : 'constructor_arg_list) _
- (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)), z) :
- 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "of";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_arg_list :
- 'constructor_arg_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'constructor_arg_list) _
- (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (Ast.TyOf (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword "|";
- Gram.Snterm
- (Gram.Entry.obj
- (constructor_declarations :
- 'constructor_declarations Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'constructor_declarations) _
- (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (Ast.TyOr (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword ";";
- Gram.Snterm
- (Gram.Entry.obj
- (label_declaration_list :
- 'label_declaration_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'label_declaration_list) _
- (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
- (Ast.TySem (_loc, x, y) : 'ctyp_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (more_ctyp : 'more_ctyp Gram.Entry.t));
- Gram.Skeyword ",";
- Gram.Snterm
- (Gram.Entry.obj
- (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (y : 'comma_ctyp) _ (x : 'more_ctyp)
- (_loc : Gram.Loc.t) ->
- (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ]))
- ());
- Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (type_parameter :
- 'type_parameter Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'type_parameter) (_loc : Gram.Loc.t)
- -> (x : 'more_ctyp))));
- ([ Gram.Snterm
- (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'ctyp) (_loc : Gram.Loc.t) ->
- (x : 'more_ctyp))));
- ([ Gram.Skeyword "`";
- Gram.Snterm
- (Gram.Entry.obj
- (a_ident : 'a_ident Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) ->
- (Ast.TyVrn (_loc, x) : 'more_ctyp))));
- ([ Gram.Skeyword "mutable"; Gram.Sself ],
- (Gram.Action.mk
- (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) ->
- (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ]))
- ());
- Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.StNil _loc : 'str_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (str_item : 'str_item Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (st : 'str_item) (_loc : Gram.Loc.t) ->
- (st : 'str_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (str_item : 'str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (st2 : 'str_item_quot) _ (st1 : 'str_item)
- (_loc : Gram.Loc.t) ->
- (match st2 with
- | Ast.StNil _ -> st1
- | _ -> Ast.StSem (_loc, st1, st2) :
- 'str_item_quot))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_expr : 'opt_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (dp : 'opt_expr) (n : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ]))
- ());
- Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.SgNil _loc : 'sig_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (sig_item : 'sig_item Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (sg : 'sig_item) (_loc : Gram.Loc.t) ->
- (sg : 'sig_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (sig_item : 'sig_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item)
- (_loc : Gram.Loc.t) ->
- (match sg2 with
- | Ast.SgNil _ -> sg1
- | _ -> Ast.SgSem (_loc, sg1, sg2) :
- 'sig_item_quot))));
- ([ Gram.Skeyword "#";
- Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_expr : 'opt_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (dp : 'opt_expr) (n : 'a_LIDENT) _
- (_loc : Gram.Loc.t) ->
- (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ]))
- ());
- Gram.extend (module_type_quot : 'module_type_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.MtNil _loc : 'module_type_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'module_type) (_loc : Gram.Loc.t) ->
- (x : 'module_type_quot)))) ]) ]))
- ());
- Gram.extend (module_expr_quot : 'module_expr_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.MeNil _loc : 'module_expr_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'module_expr) (_loc : Gram.Loc.t) ->
- (x : 'module_expr_quot)))) ]) ]))
- ());
- Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.McNil _loc : 'match_case_quot))));
- ([ Gram.Slist0sep
- ((Gram.Snterm
- (Gram.Entry.obj
- (match_case0 :
- 'match_case0 Gram.Entry.t))),
- (Gram.Skeyword "|")) ],
- (Gram.Action.mk
- (fun (x : 'match_case0 list) (_loc : Gram.Loc.t)
- -> (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ]))
- ());
- Gram.extend (binding_quot : 'binding_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.BiNil _loc : 'binding_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (binding : 'binding Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'binding) (_loc : Gram.Loc.t) ->
- (x : 'binding_quot)))) ]) ]))
- ());
- Gram.extend (rec_binding_quot : 'rec_binding_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.RbNil _loc : 'rec_binding_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (label_expr_list :
- 'label_expr_list Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'label_expr_list) (_loc : Gram.Loc.t)
- -> (x : 'rec_binding_quot)))) ]) ]))
- ());
- Gram.extend
- (module_binding_quot : 'module_binding_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.MbNil _loc : 'module_binding_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (mt : 'module_type) _
- (m : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.MbColEq (_loc, m, mt, me) :
- 'module_binding_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _ (m : 'a_UIDENT)
- (_loc : Gram.Loc.t) ->
- (Ast.MbCol (_loc, m, mt) :
- 'module_binding_quot))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)"));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t));
- Gram.Skeyword "=";
- Gram.Snterm
- (Gram.Entry.obj
- (module_expr : 'module_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (me : 'module_expr) _ (mt : 'module_type) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), m) ->
- (Ast.MbColEq (_loc, (mk_anti n m), mt,
- me) :
- 'module_binding_quot)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)"));
- Gram.Skeyword ":";
- Gram.Snterm
- (Gram.Entry.obj
- (module_type : 'module_type Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (mt : 'module_type) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), m) ->
- (Ast.MbCol (_loc, (mk_anti n m), mt) :
- 'module_binding_quot)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("", _) -> true
- | _ -> false),
- "ANTIQUOT (\"\", _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("" as n)), s) ->
- (Ast.MbAnt (_loc,
- (mk_anti ~c: "module_binding" n s)) :
- 'module_binding_quot)
- | _ -> assert false)));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("module_binding" | "anti"), _)
- -> true
- | _ -> false),
- "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("module_binding" | "anti" as n)), s)
- ->
- (Ast.MbAnt (_loc,
- (mk_anti ~c: "module_binding" n s)) :
- 'module_binding_quot)
- | _ -> assert false)));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (b2 : 'module_binding_quot) _
- (b1 : 'module_binding_quot)
- (_loc : Gram.Loc.t) ->
- (Ast.MbAnd (_loc, b1, b2) :
- 'module_binding_quot)))) ]) ]))
- ());
- Gram.extend (ident_quot : 'ident_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ ((Some "apply"), None,
- [ ([ Gram.Sself; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'ident_quot) (i : 'ident_quot)
- (_loc : Gram.Loc.t) ->
- (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]);
- ((Some "."), None,
- [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (j : 'ident_quot) _ (i : 'ident_quot)
- (_loc : Gram.Loc.t) ->
- (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]);
- ((Some "simple"), None,
- [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
- (Gram.Action.mk
- (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t)
- -> (i : 'ident_quot))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)"));
- Gram.Skeyword "."; Gram.Sself ],
- (Gram.Action.mk
- (fun (i : 'ident_quot) _
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAcc (_loc,
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s))),
- i) :
- 'ident_quot)
- | _ -> assert false)));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdLid (_loc, i) : 'ident_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
- (Ast.IdUid (_loc, i) : 'ident_quot))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT (("" | "id" | "anti" | "list"),
- _) -> true
- | _ -> false),
- "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT
- ((("" | "id" | "anti" | "list" as n)), s)
- ->
- (Ast.IdAnt (_loc,
- (mk_anti ~c: "ident" n s)) :
- 'ident_quot)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.CeNil _loc : 'class_expr_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_expr : 'class_expr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'class_expr) (_loc : Gram.Loc.t) ->
- (x : 'class_expr_quot))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("virtual", _) -> true
- | _ -> false),
- "ANTIQUOT (\"virtual\", _)"));
- Gram.Snterm
- (Gram.Entry.obj (ident : 'ident Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_comma_ctyp :
- 'opt_comma_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ot : 'opt_comma_ctyp) (i : 'ident)
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("virtual" as n)), s) ->
- (let anti =
- Ast.ViAnt
- (mk_anti ~c: "class_expr" n s)
- in Ast.CeCon (_loc, anti, i, ot) :
- 'class_expr_quot)
- | _ -> assert false)));
- ([ Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj
- (class_name_and_param :
- 'class_name_and_param Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((i, ot) : 'class_name_and_param) _
- (_loc : Gram.Loc.t) ->
- (Ast.CeCon (_loc, Ast.ViVirtual,
- (Ast.IdLid (_loc, i)), ot) :
- 'class_expr_quot))));
- ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ],
- (Gram.Action.mk
- (fun (ce2 : 'class_expr_quot) _
- (ce1 : 'class_expr_quot) (_loc : Gram.Loc.t)
- ->
- (Ast.CeEq (_loc, ce1, ce2) :
- 'class_expr_quot))));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (ce2 : 'class_expr_quot) _
- (ce1 : 'class_expr_quot) (_loc : Gram.Loc.t)
- ->
- (Ast.CeAnd (_loc, ce1, ce2) :
- 'class_expr_quot)))) ]) ]))
- ());
- Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.CtNil _loc : 'class_type_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_type_plus :
- 'class_type_plus Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'class_type_plus) (_loc : Gram.Loc.t)
- -> (x : 'class_type_quot))));
- ([ Gram.Stoken
- (((function
- | ANTIQUOT ("virtual", _) -> true
- | _ -> false),
- "ANTIQUOT (\"virtual\", _)"));
- Gram.Snterm
- (Gram.Entry.obj (ident : 'ident Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj
- (opt_comma_ctyp :
- 'opt_comma_ctyp Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (ot : 'opt_comma_ctyp) (i : 'ident)
- (__camlp4_0 : Gram.Token.t)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | ANTIQUOT ((("virtual" as n)), s) ->
- (let anti =
- Ast.ViAnt
- (mk_anti ~c: "class_type" n s)
- in Ast.CtCon (_loc, anti, i, ot) :
- 'class_type_quot)
- | _ -> assert false)));
- ([ Gram.Skeyword "virtual";
- Gram.Snterm
- (Gram.Entry.obj
- (class_name_and_param :
- 'class_name_and_param Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun ((i, ot) : 'class_name_and_param) _
- (_loc : Gram.Loc.t) ->
- (Ast.CtCon (_loc, Ast.ViVirtual,
- (Ast.IdLid (_loc, i)), ot) :
- 'class_type_quot))));
- ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ],
- (Gram.Action.mk
- (fun (ct2 : 'class_type_quot) _
- (ct1 : 'class_type_quot) (_loc : Gram.Loc.t)
- ->
- (Ast.CtCol (_loc, ct1, ct2) :
- 'class_type_quot))));
- ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ],
- (Gram.Action.mk
- (fun (ct2 : 'class_type_quot) _
- (ct1 : 'class_type_quot) (_loc : Gram.Loc.t)
- ->
- (Ast.CtEq (_loc, ct1, ct2) :
- 'class_type_quot))));
- ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
- (Gram.Action.mk
- (fun (ct2 : 'class_type_quot) _
- (ct1 : 'class_type_quot) (_loc : Gram.Loc.t)
- ->
- (Ast.CtAnd (_loc, ct1, ct2) :
- 'class_type_quot)))) ]) ]))
- ());
- Gram.extend
- (class_str_item_quot : 'class_str_item_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.CrNil _loc : 'class_str_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_str_item :
- 'class_str_item Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'class_str_item) (_loc : Gram.Loc.t)
- -> (x : 'class_str_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_str_item :
- 'class_str_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (x2 : 'class_str_item_quot) _
- (x1 : 'class_str_item) (_loc : Gram.Loc.t) ->
- (match x2 with
- | Ast.CrNil _ -> x1
- | _ -> Ast.CrSem (_loc, x1, x2) :
- 'class_str_item_quot)))) ]) ]))
- ());
- Gram.extend
- (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.CgNil _loc : 'class_sig_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_sig_item :
- 'class_sig_item Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'class_sig_item) (_loc : Gram.Loc.t)
- -> (x : 'class_sig_item_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (class_sig_item :
- 'class_sig_item Gram.Entry.t));
- Gram.Snterm
- (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
- Gram.Sself ],
- (Gram.Action.mk
- (fun (x2 : 'class_sig_item_quot) _
- (x1 : 'class_sig_item) (_loc : Gram.Loc.t) ->
- (match x2 with
- | Ast.CgNil _ -> x1
- | _ -> Ast.CgSem (_loc, x1, x2) :
- 'class_sig_item_quot)))) ]) ]))
- ());
- Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([],
- (Gram.Action.mk
- (fun (_loc : Gram.Loc.t) ->
- (Ast.WcNil _loc : 'with_constr_quot))));
- ([ Gram.Snterm
- (Gram.Entry.obj
- (with_constr : 'with_constr Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'with_constr) (_loc : Gram.Loc.t) ->
- (x : 'with_constr_quot)))) ]) ]))
- ());
- Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_rec : 'opt_rec Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'opt_rec) (_loc : Gram.Loc.t) ->
- (x : 'rec_flag_quot)))) ]) ]))
- ());
- Gram.extend
- (direction_flag_quot : 'direction_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (direction_flag :
- 'direction_flag Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'direction_flag) (_loc : Gram.Loc.t)
- -> (x : 'direction_flag_quot)))) ]) ]))
- ());
- Gram.extend
- (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_mutable : 'opt_mutable Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) ->
- (x : 'mutable_flag_quot)))) ]) ]))
- ());
- Gram.extend
- (private_flag_quot : 'private_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_private : 'opt_private Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'opt_private) (_loc : Gram.Loc.t) ->
- (x : 'private_flag_quot)))) ]) ]))
- ());
- Gram.extend
- (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_virtual : 'opt_virtual Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) ->
- (x : 'virtual_flag_quot)))) ]) ]))
- ());
- Gram.extend
- (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) ->
- (x : 'row_var_flag_quot)))) ]) ]))
- ());
- Gram.extend
- (override_flag_quot : 'override_flag_quot Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj
- (opt_override : 'opt_override Gram.Entry.t)) ],
- (Gram.Action.mk
- (fun (x : 'opt_override) (_loc : Gram.Loc.t) ->
- (x : 'override_flag_quot)))) ]) ]))
- ());
- Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
- Gram.Stoken
- (((function | EOI -> true | _ -> false), "EOI")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) (x : 'patt)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | EOI -> (x : 'patt_eoi)
- | _ -> assert false))) ]) ]))
- ());
- Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- [ ([ Gram.Snterm
- (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Stoken
- (((function | EOI -> true | _ -> false), "EOI")) ],
- (Gram.Action.mk
- (fun (__camlp4_0 : Gram.Token.t) (x : 'expr)
- (_loc : Gram.Loc.t) ->
- match __camlp4_0 with
- | EOI -> (x : 'expr_eoi)
- | _ -> assert false))) ]) ]))
- ()))
+ string_list : 'string_list Gram.Entry.t =
+ grammar_entry_create "string_list"
+ and opt_override : 'opt_override Gram.Entry.t =
+ grammar_entry_create "opt_override"
+ and unquoted_typevars : 'unquoted_typevars Gram.Entry.t =
+ grammar_entry_create "unquoted_typevars"
+ and value_val_opt_override :
+ 'value_val_opt_override Gram.Entry.t =
+ grammar_entry_create "value_val_opt_override"
+ and method_opt_override : 'method_opt_override Gram.Entry.t =
+ grammar_entry_create "method_opt_override"
+ and module_longident_dot_lparen :
+ 'module_longident_dot_lparen Gram.Entry.t =
+ grammar_entry_create "module_longident_dot_lparen"
+ and optional_type_parameter :
+ 'optional_type_parameter Gram.Entry.t =
+ grammar_entry_create "optional_type_parameter"
+ and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t =
+ grammar_entry_create "fun_def_cont_no_when"
+ and fun_def_cont : 'fun_def_cont Gram.Entry.t =
+ grammar_entry_create "fun_def_cont"
+ and sequence' : 'sequence' Gram.Entry.t =
+ grammar_entry_create "sequence'"
+ and infixop6 : 'infixop6 Gram.Entry.t =
+ grammar_entry_create "infixop6"
+ in
+ (Gram.extend (module_expr : 'module_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "top"), None,
+ [ ([ Gram.Skeyword "struct";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (str_items : 'str_items Gram.Entry.t));
+ Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t)
+ -> (Ast.MeStr (_loc, st) : 'module_expr))));
+ ([ Gram.Skeyword "functor"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.
+ Sself ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ _
+ (t : 'module_type) _ (i : 'a_UIDENT) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]);
+ ((Some "apply"), None,
+ [ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (me2 : 'module_expr) (me1 : 'module_expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (package_type :
+ 'package_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'package_type) _ (e : 'expr) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.MePkg (_loc,
+ (Ast.ExTyc (_loc, e,
+ (Ast.TyPkg (_loc, p))))) :
+ 'module_expr))));
+ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.MePkg (_loc, e) : 'module_expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (me : 'module_expr) _
+ (_loc : Gram.Loc.t) -> (me : 'module_expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (mt : 'module_type) _
+ (me : 'module_expr) _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.MeTyc (_loc, me, mt) : 'module_expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'module_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MeId (_loc, i) : 'module_expr))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.module_expr_tag :
+ 'module_expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "mexp" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "mexp" | "anti" | "list" as n)),
+ s) ->
+ (Ast.MeAnt (_loc,
+ (mk_anti ~c: "module_expr" n s)) :
+ 'module_expr)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (str_item : 'str_item Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "top"), None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.StExp (_loc, e) : 'str_item))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.str_item_tag :
+ 'str_item)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "stri" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "stri" | "anti" | "list" as n)),
+ s) ->
+ (Ast.StAnt (_loc,
+ (mk_anti ~c: "str_item" n s)) :
+ 'str_item)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "class"; Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_declaration :
+ 'class_type_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ctd : 'class_type_declaration) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StClt (_loc, ctd) : 'str_item))));
+ ([ Gram.Skeyword "class";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_declaration :
+ 'class_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (cd : 'class_declaration) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StCls (_loc, cd) : 'str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_let : 'value_let Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (binding : 'binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (bi : 'binding) (r : 'opt_rec) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StVal (_loc, r, bi) : 'str_item))));
+ ([ Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_declaration :
+ 'type_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (td : 'type_declaration) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StTyp (_loc, td) : 'str_item))));
+ ([ Gram.Skeyword "open";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'module_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StOpn (_loc, i) : 'str_item))));
+ ([ Gram.Skeyword "module"; Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ (i : 'a_ident) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StMty (_loc, i, mt) : 'str_item))));
+ ([ Gram.Skeyword "module"; Gram.Skeyword "rec";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_binding :
+ 'module_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mb : 'module_binding) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StRecMod (_loc, mb) : 'str_item))));
+ ([ Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_binding0 :
+ 'module_binding0 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mb : 'module_binding0) (i : 'a_UIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StMod (_loc, i, mb) : 'str_item))));
+ ([ Gram.Skeyword "include";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (_loc : Gram.Loc.t)
+ -> (Ast.StInc (_loc, me) : 'str_item))));
+ ([ Gram.Skeyword "external";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (string_list : 'string_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (sl : 'string_list) _ (t : 'ctyp) _
+ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.StExt (_loc, i, t, sl) : 'str_item))));
+ ([ Gram.Skeyword "exception";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_declaration :
+ 'constructor_declaration Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_longident :
+ 'type_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'type_longident) _
+ (t : 'constructor_declaration) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StExc (_loc, t, (Ast.OSome i)) :
+ 'str_item))));
+ ([ Gram.Skeyword "exception";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_declaration :
+ 'constructor_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'constructor_declaration) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StExc (_loc, t, Ast.ONone) :
+ 'str_item)))) ]) ]))
+ ());
+ Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (_loc : Gram.Loc.t)
+ -> (me : 'module_binding0))));
+ ([ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (mt : 'module_type)
+ _ (_loc : Gram.Loc.t) ->
+ (Ast.MeTyc (_loc, me, mt) :
+ 'module_binding0))));
+ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword ")"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (mb : 'module_binding0) _
+ (mt : 'module_type) _ (m : 'a_UIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.MeFun (_loc, m, mt, mb) :
+ 'module_binding0)))) ]) ]))
+ ());
+ Gram.extend (module_binding : 'module_binding Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (mt : 'module_type)
+ _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.MbColEq (_loc, m, mt, me) :
+ 'module_binding))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.module_binding_tag :
+ 'module_binding)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)"));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (mt : 'module_type)
+ _ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), m) ->
+ (Ast.MbColEq (_loc, (mk_anti n m), mt,
+ me) :
+ 'module_binding)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), s) ->
+ (Ast.MbAnt (_loc,
+ (mk_anti ~c: "module_binding" n s)) :
+ 'module_binding)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("module_binding" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("module_binding" | "anti" | "list"
+ as n)),
+ s) ->
+ (Ast.MbAnt (_loc,
+ (mk_anti ~c: "module_binding" n s)) :
+ 'module_binding)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (b2 : 'module_binding) _
+ (b1 : 'module_binding) (_loc : Gram.Loc.t)
+ ->
+ (Ast.MbAnd (_loc, b1, b2) :
+ 'module_binding)))) ]) ]))
+ ());
+ Gram.extend (module_type : 'module_type Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "top"), None,
+ [ ([ Gram.Skeyword "functor"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":"; Gram.Sself;
+ Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.
+ Sself ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ _
+ (t : 'module_type) _ (i : 'a_UIDENT) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]);
+ ((Some "with"), None,
+ [ ([ Gram.Sself; Gram.Skeyword "with";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (with_constr : 'with_constr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (wc : 'with_constr) _ (mt : 'module_type)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]);
+ ((Some "apply"), None,
+ [ ([ Gram.Sself; Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (mt2 : 'module_type)
+ (mt1 : 'module_type) (_loc : Gram.Loc.t) ->
+ (module_type_app mt1 mt2 : 'module_type)))) ]);
+ ((Some "."), None,
+ [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (mt2 : 'module_type) _
+ (mt1 : 'module_type) (_loc : Gram.Loc.t) ->
+ (module_type_acc mt1 mt2 : 'module_type)))) ]);
+ ((Some "sig"), None,
+ [ ([ Gram.Skeyword "sig";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sig_items : 'sig_items Gram.Entry.t));
+ Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t)
+ -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "module"; Gram.Skeyword "type";
+ Gram.Skeyword "of";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.MtOf (_loc, me) : 'module_type))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (mt : 'module_type) _
+ (_loc : Gram.Loc.t) -> (mt : 'module_type))));
+ ([ Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.MtQuo (_loc, i) : 'module_type))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident_with_app :
+ 'module_longident_with_app Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'module_longident_with_app)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MtId (_loc, i) : 'module_type))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.module_type_tag :
+ 'module_type)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "mtyp" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "mtyp" | "anti" | "list" as n)),
+ s) ->
+ (Ast.MtAnt (_loc,
+ (mk_anti ~c: "module_type" n s)) :
+ 'module_type)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (sig_item : 'sig_item Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "top"), None,
+ [ ([ Gram.Skeyword "class"; Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_declaration :
+ 'class_type_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ctd : 'class_type_declaration) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgClt (_loc, ctd) : 'sig_item))));
+ ([ Gram.Skeyword "class";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_description :
+ 'class_description Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (cd : 'class_description) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgCls (_loc, cd) : 'sig_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (i : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgVal (_loc, i, t) : 'sig_item))));
+ ([ Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_declaration :
+ 'type_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'type_declaration) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgTyp (_loc, t) : 'sig_item))));
+ ([ Gram.Skeyword "open";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'module_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgOpn (_loc, i) : 'sig_item))));
+ ([ Gram.Skeyword "module"; Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) :
+ 'sig_item))));
+ ([ Gram.Skeyword "module"; Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ (i : 'a_ident) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgMty (_loc, i, mt) : 'sig_item))));
+ ([ Gram.Skeyword "module"; Gram.Skeyword "rec";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_rec_declaration :
+ 'module_rec_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mb : 'module_rec_declaration) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgRecMod (_loc, mb) : 'sig_item))));
+ ([ Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_declaration :
+ 'module_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_declaration)
+ (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.SgMod (_loc, i, mt) : 'sig_item))));
+ ([ Gram.Skeyword "include";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ (_loc : Gram.Loc.t)
+ -> (Ast.SgInc (_loc, mt) : 'sig_item))));
+ ([ Gram.Skeyword "external";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (string_list : 'string_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (sl : 'string_list) _ (t : 'ctyp) _
+ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.SgExt (_loc, i, t, sl) : 'sig_item))));
+ ([ Gram.Skeyword "exception";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_declaration :
+ 'constructor_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'constructor_declaration) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgExc (_loc, t) : 'sig_item))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.sig_item_tag :
+ 'sig_item)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "sigi" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "sigi" | "anti" | "list" as n)),
+ s) ->
+ (Ast.SgAnt (_loc,
+ (mk_anti ~c: "sig_item" n s)) :
+ 'sig_item)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (module_declaration : 'module_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword ")"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (mt : 'module_declaration) _
+ (t : 'module_type) _ (i : 'a_UIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.MtFun (_loc, i, t, mt) :
+ 'module_declaration))));
+ ([ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ (_loc : Gram.Loc.t)
+ -> (mt : 'module_declaration)))) ]) ]))
+ ());
+ Gram.extend
+ (module_rec_declaration :
+ 'module_rec_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ (m : 'a_UIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MbCol (_loc, m, mt) :
+ 'module_rec_declaration))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.module_binding_tag :
+ 'module_rec_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "module_binding" | "anti" |
+ "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "module_binding" | "anti" |
+ "list"
+ as n)),
+ s) ->
+ (Ast.MbAnt (_loc,
+ (mk_anti ~c: "module_binding" n s)) :
+ 'module_rec_declaration)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (m2 : 'module_rec_declaration) _
+ (m1 : 'module_rec_declaration)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MbAnd (_loc, m1, m2) :
+ 'module_rec_declaration)))) ]) ]))
+ ());
+ Gram.extend (with_constr : 'with_constr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t));
+ Gram.Skeyword ":=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident_with_app :
+ 'module_longident_with_app Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i2 : 'module_longident_with_app) _
+ (i1 : 'module_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.WcMoS (_loc, i1, i2) : 'with_constr))));
+ ([ Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_longident_and_parameters :
+ 'type_longident_and_parameters Gram.
+ Entry.t));
+ Gram.Skeyword ":=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _
+ (t1 : 'type_longident_and_parameters) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.WcTyS (_loc, t1, t2) : 'with_constr))));
+ ([ Gram.Skeyword "type";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)"));
+ Gram.Skeyword ":=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t)
+ _ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" | "anti" as n)),
+ s) ->
+ (Ast.WcTyS (_loc,
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s))),
+ t) :
+ 'with_constr)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident_with_app :
+ 'module_longident_with_app Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i2 : 'module_longident_with_app) _
+ (i1 : 'module_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.WcMod (_loc, i1, i2) : 'with_constr))));
+ ([ Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_longident_and_parameters :
+ 'type_longident_and_parameters Gram.
+ Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _
+ (t1 : 'type_longident_and_parameters) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.WcTyp (_loc, t1, t2) : 'with_constr))));
+ ([ Gram.Skeyword "type";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)"));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t)
+ _ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" | "anti" as n)),
+ s) ->
+ (Ast.WcTyp (_loc,
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s))),
+ t) :
+ 'with_constr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.with_constr_tag :
+ 'with_constr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "with_constr" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "with_constr" | "anti" | "list"
+ as n)),
+ s) ->
+ (Ast.WcAnt (_loc,
+ (mk_anti ~c: "with_constr" n s)) :
+ 'with_constr)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (wc2 : 'with_constr) _
+ (wc1 : 'with_constr) (_loc : Gram.Loc.t) ->
+ (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ]))
+ ());
+ Gram.extend (expr : 'expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Skeyword "object";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_class_self_patt :
+ 'opt_class_self_patt Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_structure :
+ 'class_structure Gram.Entry.t));
+ Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ (cst : 'class_structure)
+ (csp : 'opt_class_self_patt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExObj (_loc, csp, cst) : 'expr))));
+ ([ Gram.Skeyword "while";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword "do";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (do_sequence : 'do_sequence Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (seq : 'do_sequence) _ (e : 'sequence) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExWhi (_loc, (mksequence' _loc e),
+ seq) :
+ 'expr))));
+ ([ Gram.Skeyword "for";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (direction_flag :
+ 'direction_flag Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword "do";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (do_sequence : 'do_sequence Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (seq : 'do_sequence) _ (e2 : 'sequence)
+ (df : 'direction_flag) (e1 : 'sequence) _
+ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExFor (_loc, i, (mksequence' _loc e1),
+ (mksequence' _loc e2), df, seq) :
+ 'expr))));
+ ([ Gram.Skeyword "do";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (do_sequence : 'do_sequence Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (seq : 'do_sequence) _
+ (_loc : Gram.Loc.t) ->
+ (mksequence _loc seq : 'expr))));
+ ([ Gram.Skeyword "if"; Gram.Sself;
+ Gram.Skeyword "then"; Gram.Sself;
+ Gram.Skeyword "else"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e3 : 'expr) _ (e2 : 'expr) _
+ (e1 : 'expr) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExIfe (_loc, e1, e2, e3) : 'expr))));
+ ([ Gram.Skeyword "try";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword "with";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (match_case : 'match_case Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (a : 'match_case) _ (e : 'sequence) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExTry (_loc, (mksequence' _loc e), a) :
+ 'expr))));
+ ([ Gram.Skeyword "match";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword "with";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (match_case : 'match_case Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (a : 'match_case) _ (e : 'sequence) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExMat (_loc, (mksequence' _loc e), a) :
+ 'expr))));
+ ([ Gram.Skeyword "fun";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_def : 'fun_def Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) ->
+ (e : 'expr))));
+ ([ Gram.Skeyword "fun"; Gram.Skeyword "[";
+ Gram.Slist0sep
+ ((Gram.Snterm
+ (Gram.Entry.obj
+ (match_case0 :
+ 'match_case0 Gram.Entry.t))),
+ (Gram.Skeyword "|"));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (a : 'match_case0 list) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) :
+ 'expr))));
+ ([ Gram.Skeyword "let"; Gram.Skeyword "open";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t));
+ Gram.Skeyword "in"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (i : 'module_longident) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExOpI (_loc, i, e) : 'expr))));
+ ([ Gram.Skeyword "let"; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_binding0 :
+ 'module_binding0 Gram.Entry.t));
+ Gram.Skeyword "in"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (mb : 'module_binding0)
+ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExLmd (_loc, m, mb, e) : 'expr))));
+ ([ Gram.Skeyword "let";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (binding : 'binding Gram.Entry.t));
+ Gram.Skeyword "in"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (x : 'expr) _ (bi : 'binding)
+ (r : 'opt_rec) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]);
+ ((Some "where"), None,
+ [ ([ Gram.Sself; Gram.Skeyword "where";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (let_binding : 'let_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (lb : 'let_binding) (rf : 'opt_rec) _
+ (e : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]);
+ ((Some ":="), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (match bigarray_set _loc e1 e2 with
+ | Some e -> e
+ | None -> Ast.ExAss (_loc, e1, e2) :
+ 'expr)))) ]);
+ ((Some "||"), (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop6 : 'infixop6 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop6)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr)))) ]);
+ ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop5 : 'infixop5 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop5)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr)))) ]);
+ ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop0 : 'infixop0 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop0)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr)))) ]);
+ ((Some "^"), (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop1 : 'infixop1 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop1)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr)))) ]);
+ ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop2 : 'infixop2 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop2)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr)))) ]);
+ ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop3 : 'infixop3 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop3)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "mod")))),
+ e1)),
+ e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "lxor")))),
+ e1)),
+ e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "lor")))),
+ e1)),
+ e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "land")))),
+ e1)),
+ e2) :
+ 'expr)))) ]);
+ ((Some "**"), (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Sself;
+ Gram.Snterm
+ (Gram.Entry.obj
+ (infixop4 : 'infixop4 Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (op : 'infixop4)
+ (e1 : 'expr) (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc, op, e1)), e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "lsr")))),
+ e1)),
+ e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "lsl")))),
+ e1)),
+ e2) :
+ 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "asr")))),
+ e1)),
+ e2) :
+ 'expr)))) ]);
+ ((Some "unary minus"),
+ (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Skeyword "-."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (mkumin _loc "-." e : 'expr))));
+ ([ Gram.Skeyword "-"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (mkumin _loc "-" e : 'expr)))) ]);
+ ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Skeyword "lazy"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExLaz (_loc, e) : 'expr))));
+ ([ Gram.Skeyword "new";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_longident :
+ 'class_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'class_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExNew (_loc, i) : 'expr))));
+ ([ Gram.Skeyword "assert"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (mkassert _loc e : 'expr))));
+ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]);
+ ((Some "label"), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Skeyword "?";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) :
+ 'expr))));
+ ([ Gram.Skeyword "?";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (i : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExOlb (_loc, i, e) : 'expr))));
+ ([ Gram.Stoken
+ (((function | OPTLABEL _ -> true | _ -> false),
+ "OPTLABEL _"));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | OPTLABEL i ->
+ (Ast.ExOlb (_loc, i, e) : 'expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function | LABEL _ -> true | _ -> false),
+ "LABEL _"));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LABEL i ->
+ (Ast.ExLab (_loc, i, e) : 'expr)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) :
+ 'expr))));
+ ([ Gram.Skeyword "~";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (i : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExLab (_loc, i, e) : 'expr)))) ]);
+ ((Some "."), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself; Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (lab : 'label) _ (e : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExSnd (_loc, e, lab) : 'expr))));
+ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExAcc (_loc, e1, e2) : 'expr))));
+ ([ Gram.Sself; Gram.Skeyword ".";
+ Gram.Skeyword "{";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_expr : 'comma_expr Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (bigarray_get _loc e1 e2 : 'expr))));
+ ([ Gram.Sself; Gram.Skeyword ".";
+ Gram.Skeyword "["; Gram.Sself;
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (e2 : 'expr) _ _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExSte (_loc, e1, e2) : 'expr))));
+ ([ Gram.Sself; Gram.Skeyword ".";
+ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (e2 : 'expr) _ _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]);
+ ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (prefixop : 'prefixop Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (f : 'prefixop)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExApp (_loc, f, e) : 'expr))));
+ ([ Gram.Skeyword "!"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExAcc (_loc, e,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, "val"))))) :
+ 'expr)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (package_type :
+ 'package_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (pt : 'package_type) _
+ (me : 'module_expr) _ _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.ExPkg (_loc,
+ (Ast.MeTyc (_loc, me, pt))) :
+ 'expr))));
+ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (me : 'module_expr) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExPkg (_loc, me) : 'expr))));
+ ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
+ 'expr))));
+ ([ Gram.Skeyword "begin";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t)
+ -> (mksequence _loc seq : 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (e : 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":>";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (e : 'expr) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) :
+ 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ":>";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _
+ (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExCoe (_loc, e, t, t2) : 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ";"; Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (mksequence _loc e : 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (seq : 'sequence) _ (e : 'expr) _
+ (_loc : Gram.Loc.t) ->
+ (mksequence _loc (Ast.ExSem (_loc, e, seq)) :
+ 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ",";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_expr : 'comma_expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (el : 'comma_expr) _ (e : 'expr) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExTup (_loc,
+ (Ast.ExCom (_loc, e, el))) :
+ 'expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (e : 'expr) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExTyc (_loc, e, t) : 'expr))));
+ ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
+ 'expr))));
+ ([ Gram.Skeyword "{<";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (field_expr_list :
+ 'field_expr_list Gram.Entry.t));
+ Gram.Skeyword ">}" ],
+ (Gram.Action.mk
+ (fun _ (fel : 'field_expr_list) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExOvr (_loc, fel) : 'expr))));
+ ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExOvr (_loc, (Ast.RbNil _loc)) :
+ 'expr))));
+ ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram.
+ Sself; Gram.Skeyword ")"; Gram.Skeyword "with";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_expr_list :
+ 'label_expr_list Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (el : 'label_expr_list) _ _ (e : 'expr)
+ _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExRec (_loc, el, e) : 'expr))));
+ ([ Gram.Skeyword "{";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_expr_list :
+ 'label_expr_list Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (el : 'label_expr_list) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) :
+ 'expr))));
+ ([ Gram.Skeyword "[|";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_expr : 'sem_expr Gram.Entry.t));
+ Gram.Skeyword "|]" ],
+ (Gram.Action.mk
+ (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t)
+ -> (Ast.ExArr (_loc, el) : 'expr))));
+ ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExArr (_loc, (Ast.ExNil _loc)) :
+ 'expr))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_expr_for_list :
+ 'sem_expr_for_list Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (mk_list : 'sem_expr_for_list) _
+ (_loc : Gram.Loc.t) ->
+ (mk_list
+ (Ast.ExId (_loc,
+ (Ast.IdUid (_loc, "[]")))) :
+ 'expr))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_expr_for_list :
+ 'sem_expr_for_list Gram.Entry.t));
+ Gram.Skeyword "::"; Gram.Sself;
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (last : 'expr) _
+ (mk_list : 'sem_expr_for_list) _
+ (_loc : Gram.Loc.t) ->
+ (mk_list last : 'expr))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) :
+ 'expr))));
+ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExVrn (_loc, s) : 'expr))));
+ ([ Gram.Stry
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (val_longident :
+ 'val_longident Gram.Entry.t))) ],
+ (Gram.Action.mk
+ (fun (i : 'val_longident) (_loc : Gram.Loc.t)
+ -> (Ast.ExId (_loc, i) : 'expr))));
+ ([ Gram.Stry
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident_dot_lparen :
+ 'module_longident_dot_lparen Gram.
+ Entry.t)));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (e : 'sequence)
+ (i : 'module_longident_dot_lparen)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExOpI (_loc, i, e) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_CHAR : 'a_CHAR Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) ->
+ (Ast.ExChr (_loc, s) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_STRING : 'a_STRING Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_STRING) (_loc : Gram.Loc.t) ->
+ (Ast.ExStr (_loc, s) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) ->
+ (Ast.ExFlo (_loc, s) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) ->
+ (Ast.ExNativeInt (_loc, s) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_INT64 : 'a_INT64 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT64) (_loc : Gram.Loc.t) ->
+ (Ast.ExInt64 (_loc, s) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_INT32 : 'a_INT32 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT32) (_loc : Gram.Loc.t) ->
+ (Ast.ExInt32 (_loc, s) : 'expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT) (_loc : Gram.Loc.t) ->
+ (Ast.ExInt (_loc, s) : 'expr))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("seq", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"seq\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("seq" as n)), s) ->
+ (Ast.ExSeq (_loc,
+ (Ast.ExAnt (_loc,
+ (mk_anti ~c: "expr" n s)))) :
+ 'expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("tup", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"tup\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("tup" as n)), s) ->
+ (Ast.ExTup (_loc,
+ (Ast.ExAnt (_loc,
+ (mk_anti ~c: "expr" n s)))) :
+ 'expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("`bool", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"`bool\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("`bool" as n)), s) ->
+ (Ast.ExId (_loc,
+ (Ast.IdAnt (_loc, (mk_anti n s)))) :
+ 'expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("exp" | "" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("exp" | "" | "anti" as n)),
+ s) ->
+ (Ast.ExAnt (_loc,
+ (mk_anti ~c: "expr" n s)) :
+ 'expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.expr_tag :
+ 'expr)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (do_sequence : 'do_sequence Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "done" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
+ 'do_sequence))));
+ ([ Gram.Stry
+ (Gram.srules do_sequence
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence :
+ 'sequence Gram.Entry.t));
+ Gram.Skeyword "done" ],
+ (Gram.Action.mk
+ (fun _ (seq : 'sequence)
+ (_loc : Gram.Loc.t) ->
+ (seq : 'e__3)))) ]) ],
+ (Gram.Action.mk
+ (fun (seq : 'e__3) (_loc : Gram.Loc.t) ->
+ (seq : 'do_sequence))));
+ ([ Gram.Stry
+ (Gram.srules do_sequence
+ [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (() : 'e__2)))) ]) ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) :
+ 'do_sequence))));
+ ([ Gram.Stry
+ (Gram.srules do_sequence
+ [ ([ Gram.Skeyword "{";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence :
+ 'sequence Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (seq : 'sequence) _
+ (_loc : Gram.Loc.t) ->
+ (seq : 'e__1)))) ]) ],
+ (Gram.Action.mk
+ (fun (seq : 'e__1) (_loc : Gram.Loc.t) ->
+ (seq : 'do_sequence)))) ]) ]))
+ ());
+ Gram.extend (infixop5 : 'infixop5 Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.srules infixop5
+ [ ([ Gram.Skeyword "&&" ],
+ (Gram.Action.mk
+ (fun (x : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ (Gram.Token.extract_string x :
+ 'e__4))));
+ ([ Gram.Skeyword "&" ],
+ (Gram.Action.mk
+ (fun (x : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ (Gram.Token.extract_string x :
+ 'e__4)))) ] ],
+ (Gram.Action.mk
+ (fun (x : 'e__4) (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) :
+ 'infixop5)))) ]) ]))
+ ());
+ Gram.extend (infixop6 : 'infixop6 Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.srules infixop6
+ [ ([ Gram.Skeyword "||" ],
+ (Gram.Action.mk
+ (fun (x : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ (Gram.Token.extract_string x :
+ 'e__5))));
+ ([ Gram.Skeyword "or" ],
+ (Gram.Action.mk
+ (fun (x : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ (Gram.Token.extract_string x :
+ 'e__5)))) ] ],
+ (Gram.Action.mk
+ (fun (x : 'e__5) (_loc : Gram.Loc.t) ->
+ (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) :
+ 'infixop6)))) ]) ]))
+ ());
+ Gram.extend
+ (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (_loc : Gram.Loc.t) ->
+ (fun acc ->
+ Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdUid (_loc, "::")))),
+ e)),
+ acc) :
+ 'sem_expr_for_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (e : 'expr) (_loc : Gram.Loc.t) ->
+ (fun acc ->
+ Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdUid (_loc, "::")))),
+ e)),
+ acc) :
+ 'sem_expr_for_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (el : 'sem_expr_for_list) _ (e : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (fun acc ->
+ Ast.ExApp (_loc,
+ (Ast.ExApp (_loc,
+ (Ast.ExId (_loc,
+ (Ast.IdUid (_loc, "::")))),
+ e)),
+ (el acc)) :
+ 'sem_expr_for_list)))) ]) ]))
+ ());
+ Gram.extend (comma_expr : 'comma_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterml
+ ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
+ "top") ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (_loc : Gram.Loc.t) ->
+ (e : 'comma_expr))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.ExAnt (_loc,
+ (mk_anti ~c: "expr," n s)) :
+ 'comma_expr)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ]))
+ ());
+ Gram.extend (dummy : 'dummy Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ]))
+ ());
+ Gram.extend (sequence' : 'sequence' Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence : 'sequence Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (el : 'sequence) _ (_loc : Gram.Loc.t) ->
+ (fun e -> Ast.ExSem (_loc, e, el) :
+ 'sequence'))));
+ ([ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (fun e -> e : 'sequence'))));
+ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (fun e -> e : 'sequence')))) ]) ]))
+ ());
+ Gram.extend (sequence : 'sequence Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence' : 'sequence' Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (k : 'sequence') (e : 'expr)
+ (_loc : Gram.Loc.t) -> (k e : 'sequence))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.ExAnt (_loc,
+ (mk_anti ~c: "expr;" n s)) :
+ 'sequence)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "let"; Gram.Skeyword "open";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_longident :
+ 'module_longident Gram.Entry.t));
+ Gram.Skeyword "in"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'sequence) _ (i : 'module_longident)
+ _ _ (_loc : Gram.Loc.t) ->
+ (Ast.ExOpI (_loc, i, e) : 'sequence))));
+ ([ Gram.Skeyword "let"; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_binding0 :
+ 'module_binding0 Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (el : 'sequence) _
+ (mb : 'module_binding0) (m : 'a_UIDENT) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExLmd (_loc, m, mb,
+ (mksequence _loc el)) :
+ 'sequence))));
+ ([ Gram.Skeyword "let"; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_binding0 :
+ 'module_binding0 Gram.Entry.t));
+ Gram.Skeyword "in";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence' : 'sequence' Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (k : 'sequence') (e : 'expr) _
+ (mb : 'module_binding0) (m : 'a_UIDENT) _ _
+ (_loc : Gram.Loc.t) ->
+ (k (Ast.ExLmd (_loc, m, mb, e)) :
+ 'sequence))));
+ ([ Gram.Skeyword "let";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (binding : 'binding Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (el : 'sequence) _ (bi : 'binding)
+ (rf : 'opt_rec) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExLet (_loc, rf, bi,
+ (mksequence _loc el)) :
+ 'sequence))));
+ ([ Gram.Skeyword "let";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (binding : 'binding Gram.Entry.t));
+ Gram.Skeyword "in";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sequence' : 'sequence' Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (k : 'sequence') (e : 'expr) _
+ (bi : 'binding) (rf : 'opt_rec) _
+ (_loc : Gram.Loc.t) ->
+ (k (Ast.ExLet (_loc, rf, bi, e)) :
+ 'sequence)))) ]) ]))
+ ());
+ Gram.extend (binding : 'binding Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (let_binding : 'let_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (b : 'let_binding) (_loc : Gram.Loc.t) ->
+ (b : 'binding))));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (b2 : 'binding) _ (b1 : 'binding)
+ (_loc : Gram.Loc.t) ->
+ (Ast.BiAnd (_loc, b1, b2) : 'binding))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.BiAnt (_loc,
+ (mk_anti ~c: "binding" n s)) :
+ 'binding)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)"));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.BiEq (_loc,
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s))),
+ e) :
+ 'binding)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("binding" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"binding\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("binding" | "list" as n)), s)
+ ->
+ (Ast.BiAnt (_loc,
+ (mk_anti ~c: "binding" n s)) :
+ 'binding)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (let_binding : 'let_binding Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_binding : 'fun_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'fun_binding) (p : 'ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ]))
+ ());
+ Gram.extend (fun_binding : 'fun_binding Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (cvalue_binding :
+ 'cvalue_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (bi : 'cvalue_binding)
+ (_loc : Gram.Loc.t) -> (bi : 'fun_binding))));
+ ([ Gram.Stry
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t)));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'fun_binding) (p : 'labeled_ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExFun (_loc,
+ (Ast.McArr (_loc, p, (Ast.ExNil _loc),
+ e))) :
+ 'fun_binding))));
+ ([ Gram.Stry
+ (Gram.srules fun_binding
+ [ ([ Gram.Skeyword "(";
+ Gram.Skeyword "type" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (() : 'e__6)))) ]);
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ")"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ]))
+ ());
+ Gram.extend (match_case : 'match_case Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t));
+ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (p : 'ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) :
+ 'match_case))));
+ ([ Gram.Skeyword "[";
+ Gram.Slist0sep
+ ((Gram.Snterm
+ (Gram.Entry.obj
+ (match_case0 :
+ 'match_case0 Gram.Entry.t))),
+ (Gram.Skeyword "|"));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (l : 'match_case0 list) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.mcOr_of_list l : 'match_case)))) ]) ]))
+ ());
+ Gram.extend (match_case0 : 'match_case0 Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (patt_as_patt_opt :
+ 'patt_as_patt_opt Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_when_expr :
+ 'opt_when_expr Gram.Entry.t));
+ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (w : 'opt_when_expr)
+ (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t)
+ ->
+ (Ast.McArr (_loc, p, w, e) : 'match_case0))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)"));
+ Gram.Skeyword "when";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (w : 'expr) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.McArr (_loc,
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s))),
+ w, e) :
+ 'match_case0)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)"));
+ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.McArr (_loc,
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s))),
+ (Ast.ExNil _loc), e) :
+ 'match_case0)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.McAnt (_loc,
+ (mk_anti ~c: "match_case" n s)) :
+ 'match_case0)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("match_case" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("match_case" | "list" as n)),
+ s) ->
+ (Ast.McAnt (_loc,
+ (mk_anti ~c: "match_case" n s)) :
+ 'match_case0)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.ExNil _loc : 'opt_when_expr))));
+ ([ Gram.Skeyword "when";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (w : 'expr) _ (_loc : Gram.Loc.t) ->
+ (w : 'opt_when_expr)))) ]) ]))
+ ());
+ Gram.extend
+ (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'patt) (_loc : Gram.Loc.t) ->
+ (p : 'patt_as_patt_opt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword "as";
+ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p2 : 'patt) _ (p1 : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaAli (_loc, p1, p2) :
+ 'patt_as_patt_opt)))) ]) ]))
+ ());
+ Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_expr : 'label_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) ->
+ (b1 : 'label_expr_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_expr : 'label_expr Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t)
+ -> (b1 : 'label_expr_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_expr : 'label_expr Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (b2 : 'label_expr_list) _
+ (b1 : 'label_expr) (_loc : Gram.Loc.t) ->
+ (Ast.RbSem (_loc, b1, b2) :
+ 'label_expr_list)))) ]) ]))
+ ());
+ Gram.extend (label_expr : 'label_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_longident :
+ 'label_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'label_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.RbEq (_loc, i,
+ (Ast.ExId (_loc,
+ (Ast.IdLid (_loc, (lid_of_ident i)))))) :
+ 'label_expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_longident :
+ 'label_longident Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_binding : 'fun_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'fun_binding) (i : 'label_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.RbEq (_loc, i, e) : 'label_expr))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.RbAnt (_loc,
+ (mk_anti ~c: "rec_binding" n s)) :
+ 'label_expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)"));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.RbEq (_loc,
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s))),
+ e) :
+ 'label_expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "anti" as n)), s) ->
+ (Ast.RbAnt (_loc,
+ (mk_anti ~c: "rec_binding" n s)) :
+ 'label_expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("rec_binding", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"rec_binding\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("rec_binding" as n)), s) ->
+ (Ast.RbAnt (_loc,
+ (mk_anti ~c: "rec_binding" n s)) :
+ 'label_expr)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (fun_def : 'fun_def Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stry
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t)));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_def_cont :
+ 'fun_def_cont Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((w, e) : 'fun_def_cont)
+ (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
+ (Ast.ExFun (_loc,
+ (Ast.McArr (_loc, p, w, e))) :
+ 'fun_def))));
+ ([ Gram.Stry
+ (Gram.srules fun_def
+ [ ([ Gram.Skeyword "(";
+ Gram.Skeyword "type" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (() : 'e__7)))) ]);
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ")";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_def_cont_no_when :
+ 'fun_def_cont_no_when Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'fun_def_cont_no_when) _
+ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ]))
+ ());
+ Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (((Ast.ExNil _loc), e) : 'fun_def_cont))));
+ ([ Gram.Skeyword "when";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (w : 'expr) _
+ (_loc : Gram.Loc.t) ->
+ ((w, e) : 'fun_def_cont))));
+ ([ Gram.Stry
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t)));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun ((w, e) : 'fun_def_cont)
+ (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
+ (((Ast.ExNil _loc),
+ (Ast.ExFun (_loc,
+ (Ast.McArr (_loc, p, w, e))))) :
+ 'fun_def_cont))));
+ ([ Gram.Stry
+ (Gram.srules fun_def_cont
+ [ ([ Gram.Skeyword "(";
+ Gram.Skeyword "type" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (() : 'e__8)))) ]);
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ")";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_def_cont_no_when :
+ 'fun_def_cont_no_when Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'fun_def_cont_no_when) _
+ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (((Ast.ExNil _loc),
+ (Ast.ExFUN (_loc, i, e))) :
+ 'fun_def_cont)))) ]) ]))
+ ());
+ Gram.extend
+ (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (e : 'fun_def_cont_no_when))));
+ ([ Gram.Stry
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t)));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_def_cont :
+ 'fun_def_cont Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((w, e) : 'fun_def_cont)
+ (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
+ (Ast.ExFun (_loc,
+ (Ast.McArr (_loc, p, w, e))) :
+ 'fun_def_cont_no_when))));
+ ([ Gram.Stry
+ (Gram.srules fun_def_cont_no_when
+ [ ([ Gram.Skeyword "(";
+ Gram.Skeyword "type" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (() : 'e__9)))) ]);
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ")"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (e : 'fun_def_cont_no_when) _
+ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (Ast.ExFUN (_loc, i, e) :
+ 'fun_def_cont_no_when)))) ]) ]))
+ ());
+ Gram.extend (patt : 'patt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'patt) _ (p1 : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]);
+ ((Some ".."), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'patt) _ (p1 : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]);
+ ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Skeyword "lazy"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p : 'patt) _ (_loc : Gram.Loc.t) ->
+ (Ast.PaLaz (_loc, p) : 'patt))));
+ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'patt) (p1 : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "?"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (patt_tcon : 'patt_tcon Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaOlbi (_loc, "", p, e) : 'patt))));
+ ([ Gram.Skeyword "?"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (patt_tcon : 'patt_tcon Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'patt_tcon) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaOlb (_loc, "", p) : 'patt))));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (Ast.PaOlb (_loc, (mk_anti n i),
+ (Ast.PaNil _loc)) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function | LIDENT _ -> true | _ -> false),
+ "LIDENT _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LIDENT i ->
+ (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)"));
+ Gram.Skeyword ":"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (patt_tcon : 'patt_tcon Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (eq_expr : 'eq_expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _
+ (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (f (mk_anti n i) p : 'patt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function | OPTLABEL _ -> true | _ -> false),
+ "OPTLABEL _"));
+ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (patt_tcon : 'patt_tcon Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (eq_expr : 'eq_expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (f : 'eq_expr) (p : 'patt_tcon) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | OPTLABEL i -> (f i p : 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function | LIDENT _ -> true | _ -> false),
+ "LIDENT _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LIDENT i ->
+ (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (Ast.PaLab (_loc, (mk_anti n i),
+ (Ast.PaNil _loc)) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)"));
+ Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t)
+ _ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (Ast.PaLab (_loc, (mk_anti n i), p) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function | LABEL _ -> true | _ -> false),
+ "LABEL _"));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p : 'patt) (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LABEL i ->
+ (Ast.PaLab (_loc, i, p) : 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_longident :
+ 'type_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'type_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyp (_loc, i) : 'patt))));
+ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.PaVrn (_loc, s) : 'patt))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.patt_tag :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.PaAny _loc : 'patt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ",";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_patt : 'comma_patt Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (pl : 'comma_patt) _ (p : 'patt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTup (_loc,
+ (Ast.PaCom (_loc, p, pl))) :
+ 'patt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword "as"; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p2 : 'patt) _ (p : 'patt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaAli (_loc, p, p2) : 'patt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (p : 'patt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, p, t) : 'patt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
+ (p : 'patt))));
+ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (package_type :
+ 'package_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (pt : 'package_type) _ (m : 'a_UIDENT)
+ _ _ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
+ (Ast.TyPkg (_loc, pt))) :
+ 'patt))));
+ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
+ -> (Ast.PaMod (_loc, m) : 'patt))));
+ ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) :
+ 'patt))));
+ ([ Gram.Skeyword "{";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_patt_list :
+ 'label_patt_list Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (pl : 'label_patt_list) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaRec (_loc, pl) : 'patt))));
+ ([ Gram.Skeyword "[|";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_patt : 'sem_patt Gram.Entry.t));
+ Gram.Skeyword "|]" ],
+ (Gram.Action.mk
+ (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t)
+ -> (Ast.PaArr (_loc, pl) : 'patt))));
+ ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.PaArr (_loc, (Ast.PaNil _loc)) :
+ 'patt))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_patt_for_list :
+ 'sem_patt_for_list Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (mk_list : 'sem_patt_for_list) _
+ (_loc : Gram.Loc.t) ->
+ (mk_list
+ (Ast.PaId (_loc,
+ (Ast.IdUid (_loc, "[]")))) :
+ 'patt))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_patt_for_list :
+ 'sem_patt_for_list Gram.Entry.t));
+ Gram.Skeyword "::"; Gram.Sself;
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (last : 'patt) _
+ (mk_list : 'sem_patt_for_list) _
+ (_loc : Gram.Loc.t) ->
+ (mk_list last : 'patt))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) :
+ 'patt))));
+ ([ Gram.Skeyword "-";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) ->
+ (Ast.PaFlo (_loc, (neg_string s)) : 'patt))));
+ ([ Gram.Skeyword "-";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.PaNativeInt (_loc, (neg_string s)) :
+ 'patt))));
+ ([ Gram.Skeyword "-";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_INT64 : 'a_INT64 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) ->
+ (Ast.PaInt64 (_loc, (neg_string s)) :
+ 'patt))));
+ ([ Gram.Skeyword "-";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_INT32 : 'a_INT32 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) ->
+ (Ast.PaInt32 (_loc, (neg_string s)) :
+ 'patt))));
+ ([ Gram.Skeyword "-";
+ Gram.Snterm
+ (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) ->
+ (Ast.PaInt (_loc, (neg_string s)) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_CHAR : 'a_CHAR Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) ->
+ (Ast.PaChr (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_STRING : 'a_STRING Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_STRING) (_loc : Gram.Loc.t) ->
+ (Ast.PaStr (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) ->
+ (Ast.PaFlo (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) ->
+ (Ast.PaNativeInt (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_INT64 : 'a_INT64 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT64) (_loc : Gram.Loc.t) ->
+ (Ast.PaInt64 (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_INT32 : 'a_INT32 Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT32) (_loc : Gram.Loc.t) ->
+ (Ast.PaInt32 (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_INT) (_loc : Gram.Loc.t) ->
+ (Ast.PaInt (_loc, s) : 'patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'ident) (_loc : Gram.Loc.t) ->
+ (Ast.PaId (_loc, i) : 'patt))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("`bool", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"`bool\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("`bool" as n)), s) ->
+ (Ast.PaId (_loc,
+ (Ast.IdAnt (_loc, (mk_anti n s)))) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("tup", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"tup\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("tup" as n)), s) ->
+ (Ast.PaTup (_loc,
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s)))) :
+ 'patt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "pat" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "pat" | "anti" as n)),
+ s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s)) :
+ 'patt)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (comma_patt : 'comma_patt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'patt) (_loc : Gram.Loc.t) ->
+ (p : 'comma_patt))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt," n s)) :
+ 'comma_patt)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ]))
+ ());
+ Gram.extend (sem_patt : 'sem_patt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'patt) (_loc : Gram.Loc.t) ->
+ (p : 'sem_patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (p : 'patt) (_loc : Gram.Loc.t) ->
+ (p : 'sem_patt))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt;" n s)) :
+ 'sem_patt)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'sem_patt) _ (p1 : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ]))
+ ());
+ Gram.extend
+ (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'patt) (_loc : Gram.Loc.t) ->
+ (fun acc ->
+ Ast.PaApp (_loc,
+ (Ast.PaApp (_loc,
+ (Ast.PaId (_loc,
+ (Ast.IdUid (_loc, "::")))),
+ p)),
+ acc) :
+ 'sem_patt_for_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (p : 'patt) (_loc : Gram.Loc.t) ->
+ (fun acc ->
+ Ast.PaApp (_loc,
+ (Ast.PaApp (_loc,
+ (Ast.PaId (_loc,
+ (Ast.IdUid (_loc, "::")))),
+ p)),
+ acc) :
+ 'sem_patt_for_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (pl : 'sem_patt_for_list) _ (p : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (fun acc ->
+ Ast.PaApp (_loc,
+ (Ast.PaApp (_loc,
+ (Ast.PaId (_loc,
+ (Ast.IdUid (_loc, "::")))),
+ p)),
+ (pl acc)) :
+ 'sem_patt_for_list)))) ]) ]))
+ ());
+ Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_patt : 'label_patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) ->
+ (p1 : 'label_patt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_patt : 'label_patt Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t)
+ -> (p1 : 'label_patt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_patt : 'label_patt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Skeyword "_";
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ _ _ (p1 : 'label_patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
+ 'label_patt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_patt : 'label_patt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ _ (p1 : 'label_patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
+ 'label_patt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_patt : 'label_patt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'label_patt_list) _
+ (p1 : 'label_patt) (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, p2) :
+ 'label_patt_list)))) ]) ]))
+ ());
+ Gram.extend (label_patt : 'label_patt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_longident :
+ 'label_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'label_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaEq (_loc, i,
+ (Ast.PaId (_loc,
+ (Ast.IdLid (_loc, (lid_of_ident i)))))) :
+ 'label_patt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_longident :
+ 'label_longident Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'patt) _ (i : 'label_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaEq (_loc, i, p) : 'label_patt))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt;" n s)) :
+ 'label_patt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.patt_tag :
+ 'label_patt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "pat" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "pat" | "anti" as n)),
+ s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s)) :
+ 'label_patt)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (ipatt : 'ipatt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.PaAny _loc : 'ipatt))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) :
+ 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ",";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_ipatt : 'comma_ipatt Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTup (_loc,
+ (Ast.PaCom (_loc, p, pl))) :
+ 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword "as"; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaAli (_loc, p, p2) : 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (p : 'ipatt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, p, t) : 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) ->
+ (p : 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (package_type :
+ 'package_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (pt : 'package_type) _ (m : 'a_UIDENT)
+ _ _ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
+ (Ast.TyPkg (_loc, pt))) :
+ 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
+ -> (Ast.PaMod (_loc, m) : 'ipatt))));
+ ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) :
+ 'ipatt))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.patt_tag :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("tup", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"tup\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("tup" as n)), s) ->
+ (Ast.PaTup (_loc,
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s)))) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "pat" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "pat" | "anti" as n)),
+ s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s)) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "{";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_ipatt_list :
+ 'label_ipatt_list Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (pl : 'label_ipatt_list) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ]))
+ ());
+ Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'ipatt) (_loc : Gram.Loc.t) ->
+ (p : 'labeled_ipatt)))) ]) ]))
+ ());
+ Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'ipatt) (_loc : Gram.Loc.t) ->
+ (p : 'comma_ipatt))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt," n s)) :
+ 'comma_ipatt)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ]))
+ ());
+ Gram.extend
+ (label_ipatt_list : 'label_ipatt_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_ipatt : 'label_ipatt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t)
+ -> (p1 : 'label_ipatt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_ipatt : 'label_ipatt Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t)
+ -> (p1 : 'label_ipatt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_ipatt : 'label_ipatt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Skeyword "_";
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ _ _ (p1 : 'label_ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
+ 'label_ipatt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_ipatt : 'label_ipatt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ _ (p1 : 'label_ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
+ 'label_ipatt_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_ipatt : 'label_ipatt Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p2 : 'label_ipatt_list) _
+ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, p1, p2) :
+ 'label_ipatt_list)))) ]) ]))
+ ());
+ Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_longident :
+ 'label_longident Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'ipatt) _ (i : 'label_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaEq (_loc, i, p) : 'label_ipatt))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.patt_tag :
+ 'label_ipatt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt;" n s)) :
+ 'label_ipatt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "pat" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "pat" | "anti" as n)),
+ s) ->
+ (Ast.PaAnt (_loc,
+ (mk_anti ~c: "patt" n s)) :
+ 'label_ipatt)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (type_declaration : 'type_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_ident_and_parameters :
+ 'type_ident_and_parameters Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t));
+ Gram.Slist0
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (constrain : 'constrain Gram.Entry.t))) ],
+ (Gram.Action.mk
+ (fun (cl : 'constrain list)
+ (tk : 'opt_eq_ctyp)
+ ((n, tpl) : 'type_ident_and_parameters)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyDcl (_loc, n, tpl, tk, cl) :
+ 'type_declaration))));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'type_declaration) _
+ (t1 : 'type_declaration)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyAnd (_loc, t1, t2) :
+ 'type_declaration))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'type_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctypand" n s)) :
+ 'type_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" | "anti" as n)),
+ s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'type_declaration)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (constrain : 'constrain Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "constraint";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
+ (_loc : Gram.Loc.t) ->
+ ((t1, t2) : 'constrain)))) ]) ]))
+ ());
+ Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.TyNil _loc : 'opt_eq_ctyp))));
+ ([ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_kind : 'type_kind Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t)
+ -> (tk : 'opt_eq_ctyp)))) ]) ]))
+ ());
+ Gram.extend (type_kind : 'type_kind Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'type_kind)))) ]) ]))
+ ());
+ Gram.extend
+ (type_ident_and_parameters :
+ 'type_ident_and_parameters Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Slist0
+ (Gram.Snterm
+ (Gram.Entry.obj
+ (optional_type_parameter :
+ 'optional_type_parameter Gram.Entry.t))) ],
+ (Gram.Action.mk
+ (fun (tpl : 'optional_type_parameter list)
+ (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ ((i, tpl) : 'type_ident_and_parameters)))) ]) ]))
+ ());
+ Gram.extend
+ (type_longident_and_parameters :
+ 'type_longident_and_parameters Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_longident :
+ 'type_longident Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (type_parameters :
+ 'type_parameters Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (tpl : 'type_parameters)
+ (i : 'type_longident) (_loc : Gram.Loc.t)
+ ->
+ (tpl (Ast.TyId (_loc, i)) :
+ 'type_longident_and_parameters)))) ]) ]))
+ ());
+ Gram.extend (type_parameters : 'type_parameters Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (fun t -> t : 'type_parameters))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_parameter :
+ 'type_parameter Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'type_parameter) (_loc : Gram.Loc.t)
+ ->
+ (fun acc -> Ast.TyApp (_loc, acc, t) :
+ 'type_parameters))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_parameter :
+ 'type_parameter Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'type_parameters)
+ (t1 : 'type_parameter) (_loc : Gram.Loc.t)
+ ->
+ (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) :
+ 'type_parameters)))) ]) ]))
+ ());
+ Gram.extend (type_parameter : 'type_parameter Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "-"; Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuM (_loc, i) : 'type_parameter))));
+ ([ Gram.Skeyword "+"; Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuP (_loc, i) : 'type_parameter))));
+ ([ Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuo (_loc, i) : 'type_parameter))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'type_parameter)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" | "anti" as n)),
+ s) ->
+ (Ast.TyAnt (_loc, (mk_anti n s)) :
+ 'type_parameter)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (optional_type_parameter :
+ 'optional_type_parameter Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.TyAny _loc : 'optional_type_parameter))));
+ ([ Gram.Skeyword "-"; Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyAnM _loc : 'optional_type_parameter))));
+ ([ Gram.Skeyword "+"; Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyAnP _loc : 'optional_type_parameter))));
+ ([ Gram.Skeyword "-"; Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuM (_loc, i) :
+ 'optional_type_parameter))));
+ ([ Gram.Skeyword "+"; Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuP (_loc, i) :
+ 'optional_type_parameter))));
+ ([ Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuo (_loc, i) :
+ 'optional_type_parameter))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'optional_type_parameter)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" | "anti" as n)),
+ s) ->
+ (Ast.TyAnt (_loc, (mk_anti n s)) :
+ 'optional_type_parameter)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (ctyp : 'ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]);
+ ((Some "private"), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Skeyword "private";
+ Gram.Snterml
+ ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)),
+ "alias") ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyPrv (_loc, t) : 'ctyp)))) ]);
+ ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]);
+ ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Skeyword "!";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (typevars : 'typevars Gram.Entry.t));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'typevars) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]);
+ ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA),
+ [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]);
+ ((Some "label"), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (i : 'a_OPTLABEL)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOlb (_loc, i, t) : 'ctyp))));
+ ([ Gram.Skeyword "?";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (i : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOlb (_loc, i, t) : 'ctyp))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LABEL : 'a_LABEL Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (i : 'a_LABEL)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyLab (_loc, i, t) : 'ctyp))));
+ ([ Gram.Skeyword "~";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (i : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]);
+ ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) (t1 : 'ctyp)
+ (_loc : Gram.Loc.t) ->
+ (let t = Ast.TyApp (_loc, t1, t2)
+ in
+ try
+ Ast.TyId (_loc, (Ast.ident_of_ctyp t))
+ with | Invalid_argument _ -> t :
+ 'ctyp)))) ]);
+ ((Some "."), (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp)
+ (_loc : Gram.Loc.t) ->
+ (try
+ Ast.TyId (_loc,
+ (Ast.IdAcc (_loc,
+ (Ast.ident_of_ctyp t1),
+ (Ast.ident_of_ctyp t2))))
+ with
+ | Invalid_argument s ->
+ raise (Stream.Error s) :
+ 'ctyp)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "("; Gram.Skeyword "module";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (package_type :
+ 'package_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'package_type) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyPkg (_loc, p) : 'ctyp))));
+ ([ Gram.Skeyword "<";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_meth_list :
+ 'opt_meth_list Gram.Entry.t));
+ Gram.Skeyword ">" ],
+ (Gram.Action.mk
+ (fun _ (t : 'opt_meth_list) _
+ (_loc : Gram.Loc.t) -> (t : 'ctyp))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_longident :
+ 'class_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'class_longident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCls (_loc, i) : 'ctyp))));
+ ([ Gram.Skeyword "{";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_declaration_list :
+ 'label_declaration_list Gram.Entry.t));
+ Gram.Skeyword "}" ],
+ (Gram.Action.mk
+ (fun _ (t : 'label_declaration_list) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyRec (_loc, t) : 'ctyp))));
+ ([ Gram.Skeyword "[<";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t));
+ Gram.Skeyword ">";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (name_tags : 'name_tags Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (ntl : 'name_tags) _ (rfl : 'row_field)
+ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp))));
+ ([ Gram.Skeyword "[<";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (rfl : 'row_field) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnInf (_loc, rfl) : 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "<";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t));
+ Gram.Skeyword ">";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (name_tags : 'name_tags Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (ntl : 'name_tags) _ (rfl : 'row_field)
+ _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "<";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (rfl : 'row_field) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnInf (_loc, rfl) : 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword ">";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (rfl : 'row_field) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnSup (_loc, rfl) : 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword ">";
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) :
+ 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (rfl : 'row_field) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrnEq (_loc, rfl) : 'ctyp))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_declarations :
+ 'constructor_declarations Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (t : 'constructor_declarations) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TySum (_loc, t) : 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TySum (_loc, (Ast.TyNil _loc)) :
+ 'ctyp))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
+ (t : 'ctyp))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword "*";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (star_ctyp : 'star_ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyTup (_loc,
+ (Ast.TySta (_loc, t, tl))) :
+ 'ctyp))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) :
+ 'ctyp))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) :
+ 'ctyp))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'ctyp)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("id", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"id\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("id" as n)), s) ->
+ (Ast.TyId (_loc,
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)))) :
+ 'ctyp)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("tup", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"tup\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("tup" as n)), s) ->
+ (Ast.TyTup (_loc,
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)))) :
+ 'ctyp)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" | "anti" as n)),
+ s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'ctyp)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "_" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.TyAny _loc : 'ctyp))));
+ ([ Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ]))
+ ());
+ Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'star_ctyp))));
+ ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TySta (_loc, t1, t2) : 'star_ctyp))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp*" n s)) :
+ 'star_ctyp)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'star_ctyp)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (constructor_declarations :
+ 'constructor_declarations Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) :
+ 'constructor_declarations))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (s : 'a_UIDENT)
+ (_loc : Gram.Loc.t) ->
+ (let (tl, rt) = generalized_type_of_type t
+ in
+ Ast.TyCol (_loc,
+ (Ast.TyId (_loc,
+ (Ast.IdUid (_loc, s)))),
+ (Ast.TyArr (_loc,
+ (Ast.tyAnd_of_list tl), rt))) :
+ 'constructor_declarations))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "of";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_arg_list :
+ 'constructor_arg_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'constructor_arg_list) _
+ (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.TyOf (_loc,
+ (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
+ t) :
+ 'constructor_declarations))));
+ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'constructor_declarations) _
+ (t1 : 'constructor_declarations)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOr (_loc, t1, t2) :
+ 'constructor_declarations))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'constructor_declarations)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp|" n s)) :
+ 'constructor_declarations)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'constructor_declarations)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (constructor_declaration :
+ 'constructor_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) :
+ 'constructor_declaration))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "of";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_arg_list :
+ 'constructor_arg_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'constructor_arg_list) _
+ (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.TyOf (_loc,
+ (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
+ t) :
+ 'constructor_declaration))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'constructor_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'constructor_declaration)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'constructor_arg_list))));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'constructor_arg_list) _
+ (t1 : 'constructor_arg_list)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyAnd (_loc, t1, t2) :
+ 'constructor_arg_list))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctypand" n s)) :
+ 'constructor_arg_list)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (label_declaration_list :
+ 'label_declaration_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_declaration :
+ 'label_declaration Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t1 : 'label_declaration)
+ (_loc : Gram.Loc.t) ->
+ (t1 : 'label_declaration_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_declaration :
+ 'label_declaration Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (t1 : 'label_declaration)
+ (_loc : Gram.Loc.t) ->
+ (t1 : 'label_declaration_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_declaration :
+ 'label_declaration Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'label_declaration_list) _
+ (t1 : 'label_declaration)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TySem (_loc, t1, t2) :
+ 'label_declaration_list)))) ]) ]))
+ ());
+ Gram.extend
+ (label_declaration : 'label_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":"; Gram.Skeyword "mutable";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ _ (s : 'a_LIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCol (_loc,
+ (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))),
+ (Ast.TyMut (_loc, t))) :
+ 'label_declaration))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (s : 'a_LIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCol (_loc,
+ (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))),
+ t) :
+ 'label_declaration))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'label_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp;" n s)) :
+ 'label_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'label_declaration)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_ident : 'a_ident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (i : 'a_ident))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (i : 'a_ident)))) ]) ]))
+ ());
+ Gram.extend (ident : 'ident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'ident) _ (i : 'a_UIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) :
+ 'ident))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)"));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (i : 'ident) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAcc (_loc,
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s))),
+ i) :
+ 'ident)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdLid (_loc, i) : 'ident))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdUid (_loc, i) : 'ident))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'ident)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (module_longident : 'module_longident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdUid (_loc, i) : 'module_longident))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (l : 'module_longident) _ (m : 'a_UIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) :
+ 'module_longident))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'module_longident)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (module_longident_with_app :
+ 'module_longident_with_app Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "apply"), None,
+ [ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'module_longident_with_app)
+ (i : 'module_longident_with_app)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdApp (_loc, i, j) :
+ 'module_longident_with_app)))) ]);
+ ((Some "."), None,
+ [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'module_longident_with_app) _
+ (i : 'module_longident_with_app)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdAcc (_loc, i, j) :
+ 'module_longident_with_app)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (i : 'module_longident_with_app) _
+ (_loc : Gram.Loc.t) ->
+ (i : 'module_longident_with_app))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdUid (_loc, i) :
+ 'module_longident_with_app))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'module_longident_with_app)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (module_longident_dot_lparen :
+ 'module_longident_dot_lparen Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "."; Gram.Skeyword "(" ],
+ (Gram.Action.mk
+ (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t)
+ ->
+ (Ast.IdUid (_loc, i) :
+ 'module_longident_dot_lparen))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (l : 'module_longident_dot_lparen) _
+ (m : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) :
+ 'module_longident_dot_lparen))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)"));
+ Gram.Skeyword "."; Gram.Skeyword "(" ],
+ (Gram.Action.mk
+ (fun _ _ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'module_longident_dot_lparen)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (type_longident : 'type_longident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "apply"), None,
+ [ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'type_longident)
+ (i : 'type_longident) (_loc : Gram.Loc.t)
+ ->
+ (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]);
+ ((Some "."), None,
+ [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'type_longident) _
+ (i : 'type_longident) (_loc : Gram.Loc.t)
+ ->
+ (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (i : 'type_longident) _
+ (_loc : Gram.Loc.t) ->
+ (i : 'type_longident))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdUid (_loc, i) : 'type_longident))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdLid (_loc, i) : 'type_longident))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'type_longident)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (label_longident : 'label_longident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdLid (_loc, i) : 'label_longident))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (l : 'label_longident) _ (m : 'a_UIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) :
+ 'label_longident))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'label_longident)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (class_type_longident : 'class_type_longident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_longident :
+ 'type_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'type_longident) (_loc : Gram.Loc.t)
+ -> (x : 'class_type_longident)))) ]) ]))
+ ());
+ Gram.extend (val_longident : 'val_longident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'ident) (_loc : Gram.Loc.t) ->
+ (x : 'val_longident)))) ]) ]))
+ ());
+ Gram.extend (class_longident : 'class_longident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_longident :
+ 'label_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'label_longident)
+ (_loc : Gram.Loc.t) ->
+ (x : 'class_longident)))) ]) ]))
+ ());
+ Gram.extend
+ (class_declaration : 'class_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_info_for_class_expr :
+ 'class_info_for_class_expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_fun_binding :
+ 'class_fun_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ce : 'class_fun_binding)
+ (ci : 'class_info_for_class_expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeEq (_loc, ci, ce) :
+ 'class_declaration))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_expr_tag :
+ 'class_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "cdcl" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "cdcl" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CeAnt (_loc,
+ (mk_anti ~c: "class_expr" n s)) :
+ 'class_declaration)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (c2 : 'class_declaration) _
+ (c1 : 'class_declaration)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeAnd (_loc, c1, c2) :
+ 'class_declaration)))) ]) ]))
+ ());
+ Gram.extend
+ (class_fun_binding : 'class_fun_binding Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (cfb : 'class_fun_binding)
+ (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
+ (Ast.CeFun (_loc, p, cfb) :
+ 'class_fun_binding))));
+ ([ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_plus :
+ 'class_type_plus Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_expr : 'class_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ce : 'class_expr) _
+ (ct : 'class_type_plus) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeTyc (_loc, ce, ct) :
+ 'class_fun_binding))));
+ ([ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_expr : 'class_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t)
+ -> (ce : 'class_fun_binding)))) ]) ]))
+ ());
+ Gram.extend
+ (class_info_for_class_type :
+ 'class_info_for_class_type Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_virtual : 'opt_virtual Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_name_and_param :
+ 'class_name_and_param Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((i, ot) : 'class_name_and_param)
+ (mv : 'opt_virtual) (_loc : Gram.Loc.t) ->
+ (Ast.CtCon (_loc, mv,
+ (Ast.IdLid (_loc, i)), ot) :
+ 'class_info_for_class_type)))) ]) ]))
+ ());
+ Gram.extend
+ (class_info_for_class_expr :
+ 'class_info_for_class_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_virtual : 'opt_virtual Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_name_and_param :
+ 'class_name_and_param Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((i, ot) : 'class_name_and_param)
+ (mv : 'opt_virtual) (_loc : Gram.Loc.t) ->
+ (Ast.CeCon (_loc, mv,
+ (Ast.IdLid (_loc, i)), ot) :
+ 'class_info_for_class_expr)))) ]) ]))
+ ());
+ Gram.extend
+ (class_name_and_param : 'class_name_and_param Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ ((i, (Ast.TyNil _loc)) :
+ 'class_name_and_param))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_type_parameter :
+ 'comma_type_parameter Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (x : 'comma_type_parameter) _
+ (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ ((i, x) : 'class_name_and_param)))) ]) ]))
+ ());
+ Gram.extend
+ (comma_type_parameter : 'comma_type_parameter Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_parameter :
+ 'type_parameter Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'type_parameter) (_loc : Gram.Loc.t)
+ -> (t : 'comma_type_parameter))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp," n s)) :
+ 'comma_type_parameter)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'comma_type_parameter) _
+ (t1 : 'comma_type_parameter)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCom (_loc, t1, t2) :
+ 'comma_type_parameter)))) ]) ]))
+ ());
+ Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.TyNil _loc : 'opt_comma_ctyp))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_ctyp : 'comma_ctyp Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t)
+ -> (x : 'opt_comma_ctyp)))) ]) ]))
+ ());
+ Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'comma_ctyp))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp," n s)) :
+ 'comma_ctyp)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ]))
+ ());
+ Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "->";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_expr : 'class_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t)
+ -> (ce : 'class_fun_def))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ce : 'class_fun_def)
+ (p : 'labeled_ipatt) (_loc : Gram.Loc.t) ->
+ (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ]))
+ ());
+ Gram.extend (class_expr : 'class_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "top"), None,
+ [ ([ Gram.Skeyword "let";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (binding : 'binding Gram.Entry.t));
+ Gram.Skeyword "in"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ce : 'class_expr) _ (bi : 'binding)
+ (rf : 'opt_rec) _ (_loc : Gram.Loc.t) ->
+ (Ast.CeLet (_loc, rf, bi, ce) :
+ 'class_expr))));
+ ([ Gram.Skeyword "fun";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (labeled_ipatt :
+ 'labeled_ipatt Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_fun_def :
+ 'class_fun_def Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ce : 'class_fun_def)
+ (p : 'labeled_ipatt) _ (_loc : Gram.Loc.t)
+ -> (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]);
+ ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA),
+ [ ([ Gram.Sself;
+ Gram.Snterml
+ ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
+ "label") ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (ce : 'class_expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (ce : 'class_expr) _
+ (_loc : Gram.Loc.t) -> (ce : 'class_expr))));
+ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type : 'class_type Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (ct : 'class_type) _ (ce : 'class_expr)
+ _ (_loc : Gram.Loc.t) ->
+ (Ast.CeTyc (_loc, ce, ct) : 'class_expr))));
+ ([ Gram.Skeyword "object";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_class_self_patt :
+ 'opt_class_self_patt Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_structure :
+ 'class_structure Gram.Entry.t));
+ Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ (cst : 'class_structure)
+ (csp : 'opt_class_self_patt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeStr (_loc, csp, cst) : 'class_expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_longident_and_param :
+ 'class_longident_and_param Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ce : 'class_longident_and_param)
+ (_loc : Gram.Loc.t) -> (ce : 'class_expr))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_expr_tag :
+ 'class_expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "cexp" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "cexp" | "anti" as n)),
+ s) ->
+ (Ast.CeAnt (_loc,
+ (mk_anti ~c: "class_expr" n s)) :
+ 'class_expr)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (class_longident_and_param :
+ 'class_longident_and_param Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_longident :
+ 'class_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ci : 'class_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeCon (_loc, Ast.ViNil, ci,
+ (Ast.TyNil _loc)) :
+ 'class_longident_and_param))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_longident :
+ 'class_longident Gram.Entry.t));
+ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_ctyp : 'comma_ctyp Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (t : 'comma_ctyp) _
+ (ci : 'class_longident) (_loc : Gram.Loc.t)
+ ->
+ (Ast.CeCon (_loc, Ast.ViNil, ci, t) :
+ 'class_longident_and_param)))) ]) ]))
+ ());
+ Gram.extend (class_structure : 'class_structure Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Slist0
+ (Gram.srules class_structure
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_str_item :
+ 'class_str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (cst : 'class_str_item)
+ (_loc : Gram.Loc.t) ->
+ (cst : 'e__10)))) ]) ],
+ (Gram.Action.mk
+ (fun (l : 'e__10 list) (_loc : Gram.Loc.t) ->
+ (Ast.crSem_of_list l : 'class_structure))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "cst" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)"));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (cst : 'class_structure) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "cst" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CrSem (_loc,
+ (Ast.CrAnt (_loc,
+ (mk_anti ~c: "class_str_item" n s))),
+ cst) :
+ 'class_structure)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "cst" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "cst" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CrAnt (_loc,
+ (mk_anti ~c: "class_str_item" n s)) :
+ 'class_structure)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.PaNil _loc : 'opt_class_self_patt))));
+ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (p : 'patt) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, p, t) :
+ 'opt_class_self_patt))));
+ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
+ (p : 'opt_class_self_patt)))) ]) ]))
+ ());
+ Gram.extend (class_str_item : 'class_str_item Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Skeyword "initializer";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (se : 'expr) _ (_loc : Gram.Loc.t) ->
+ (Ast.CrIni (_loc, se) : 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_constraint :
+ 'type_constraint Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CrCtr (_loc, t1, t2) :
+ 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (method_opt_override :
+ 'method_opt_override Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t));
+ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label) _
+ (pf : 'opt_private)
+ (o : 'method_opt_override)
+ (_loc : Gram.Loc.t) ->
+ (if o <> Ast.OvNil
+ then
+ raise
+ (Stream.Error
+ "override (!) is incompatible with virtual")
+ else Ast.CrVir (_loc, l, pf, t) :
+ 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (method_opt_override :
+ 'method_opt_override Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_polyt : 'opt_polyt Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (fun_binding : 'fun_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'fun_binding) (topt : 'opt_polyt)
+ (l : 'label) (pf : 'opt_private)
+ (o : 'method_opt_override)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CrMth (_loc, l, o, pf, e, topt) :
+ 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (method_opt_override :
+ 'method_opt_override Gram.Entry.t));
+ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label)
+ (pf : 'opt_private) _
+ (o : 'method_opt_override)
+ (_loc : Gram.Loc.t) ->
+ (if o <> Ast.OvNil
+ then
+ raise
+ (Stream.Error
+ "override (!) is incompatible with virtual")
+ else Ast.CrVir (_loc, l, pf, t) :
+ 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val_opt_override :
+ 'value_val_opt_override Gram.Entry.t));
+ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_mutable : 'opt_mutable Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label)
+ (mf : 'opt_mutable) _
+ (o : 'value_val_opt_override)
+ (_loc : Gram.Loc.t) ->
+ (if o <> Ast.OvNil
+ then
+ raise
+ (Stream.Error
+ "override (!) is incompatible with virtual")
+ else Ast.CrVvr (_loc, l, mf, t) :
+ 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val_opt_override :
+ 'value_val_opt_override Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_mutable : 'opt_mutable Gram.Entry.t));
+ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label) _
+ (mf : 'opt_mutable)
+ (o : 'value_val_opt_override)
+ (_loc : Gram.Loc.t) ->
+ (if o <> Ast.OvNil
+ then
+ raise
+ (Stream.Error
+ "override (!) is incompatible with virtual")
+ else Ast.CrVvr (_loc, l, mf, t) :
+ 'class_str_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val_opt_override :
+ 'value_val_opt_override Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_mutable : 'opt_mutable Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (cvalue_binding :
+ 'cvalue_binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'cvalue_binding) (lab : 'label)
+ (mf : 'opt_mutable)
+ (o : 'value_val_opt_override)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CrVal (_loc, lab, o, mf, e) :
+ 'class_str_item))));
+ ([ Gram.Skeyword "inherit";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_override :
+ 'opt_override Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_expr : 'class_expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_as_lident :
+ 'opt_as_lident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (pb : 'opt_as_lident) (ce : 'class_expr)
+ (o : 'opt_override) _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.CrInh (_loc, o, ce, pb) :
+ 'class_str_item))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_str_item_tag :
+ 'class_str_item)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "cst" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "cst" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CrAnt (_loc,
+ (mk_anti ~c: "class_str_item" n s)) :
+ 'class_str_item)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (method_opt_override : 'method_opt_override Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "method" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.OvNil : 'method_opt_override))));
+ ([ Gram.Skeyword "method";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("!" | "override" | "anti"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("!" | "override" | "anti" as n)), s)
+ ->
+ (Ast.OvAnt (mk_anti n s) :
+ 'method_opt_override)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "method"; Gram.Skeyword "!" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.OvOverride : 'method_opt_override)))) ]) ]))
+ ());
+ Gram.extend
+ (value_val_opt_override :
+ 'value_val_opt_override Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.OvNil : 'value_val_opt_override))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t));
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("!" | "override" | "anti"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("!" | "override" | "anti" as n)), s)
+ ->
+ (Ast.OvAnt (mk_anti n s) :
+ 'value_val_opt_override)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t));
+ Gram.Skeyword "!" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.OvOverride : 'value_val_opt_override)))) ]) ]))
+ ());
+ Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ ("" : 'opt_as_lident))));
+ ([ Gram.Skeyword "as";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) ->
+ (i : 'opt_as_lident)))) ]) ]))
+ ());
+ Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.TyNil _loc : 'opt_polyt))));
+ ([ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) ->
+ (t : 'opt_polyt)))) ]) ]))
+ ());
+ Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword ":>";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (t : 'ctyp) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) :
+ 'cvalue_binding))));
+ ([ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t));
+ Gram.Skeyword ":>";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (t2 : 'ctyp) _
+ (t : 'poly_type) _ (_loc : Gram.Loc.t) ->
+ (match t with
+ | Ast.TyPol (_, _, _) ->
+ raise
+ (Stream.Error
+ "unexpected polytype here")
+ | _ -> Ast.ExCoe (_loc, e, t, t2) :
+ 'cvalue_binding))));
+ ([ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (t : 'poly_type) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExTyc (_loc, e, t) : 'cvalue_binding))));
+ ([ Gram.Skeyword ":"; Gram.Skeyword "type";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (unquoted_typevars :
+ 'unquoted_typevars Gram.Entry.t));
+ Gram.Skeyword ".";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (t2 : 'ctyp) _
+ (t1 : 'unquoted_typevars) _ _
+ (_loc : Gram.Loc.t) ->
+ (let u = Ast.TyTypePol (_loc, t1, t2)
+ in Ast.ExTyc (_loc, e, u) :
+ 'cvalue_binding))));
+ ([ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (e : 'cvalue_binding)))) ]) ]))
+ ());
+ Gram.extend (label : 'label Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (i : 'label)))) ]) ]))
+ ());
+ Gram.extend (class_type : 'class_type Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "object";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_class_self_type :
+ 'opt_class_self_type Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_signature :
+ 'class_signature Gram.Entry.t));
+ Gram.Skeyword "end" ],
+ (Gram.Action.mk
+ (fun _ (csg : 'class_signature)
+ (cst : 'opt_class_self_type) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtSig (_loc, cst, csg) : 'class_type))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_longident_and_param :
+ 'class_type_longident_and_param Gram.
+ Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ct : 'class_type_longident_and_param)
+ (_loc : Gram.Loc.t) -> (ct : 'class_type))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_type_tag :
+ 'class_type)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "ctyp" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "ctyp" | "anti" as n)),
+ s) ->
+ (Ast.CtAnt (_loc,
+ (mk_anti ~c: "class_type" n s)) :
+ 'class_type)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend
+ (class_type_longident_and_param :
+ 'class_type_longident_and_param Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_longident :
+ 'class_type_longident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'class_type_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtCon (_loc, Ast.ViNil, i,
+ (Ast.TyNil _loc)) :
+ 'class_type_longident_and_param))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_longident :
+ 'class_type_longident Gram.Entry.t));
+ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_ctyp : 'comma_ctyp Gram.Entry.t));
+ Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ (t : 'comma_ctyp) _
+ (i : 'class_type_longident)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtCon (_loc, Ast.ViNil, i, t) :
+ 'class_type_longident_and_param)))) ]) ]))
+ ());
+ Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type : 'class_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ct : 'class_type) (_loc : Gram.Loc.t) ->
+ (ct : 'class_type_plus))));
+ ([ Gram.Skeyword "[";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "]"; Gram.Skeyword "->"; Gram.
+ Sself ],
+ (Gram.Action.mk
+ (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtFun (_loc, t, ct) :
+ 'class_type_plus)))) ]) ]))
+ ());
+ Gram.extend
+ (opt_class_self_type : 'opt_class_self_type Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.TyNil _loc : 'opt_class_self_type))));
+ ([ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
+ (t : 'opt_class_self_type)))) ]) ]))
+ ());
+ Gram.extend (class_signature : 'class_signature Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Slist0
+ (Gram.srules class_signature
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_sig_item :
+ 'class_sig_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (csg : 'class_sig_item)
+ (_loc : Gram.Loc.t) ->
+ (csg : 'e__11)))) ]) ],
+ (Gram.Action.mk
+ (fun (l : 'e__11 list) (_loc : Gram.Loc.t) ->
+ (Ast.cgSem_of_list l : 'class_signature))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "csg" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)"));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (csg : 'class_signature) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "csg" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CgSem (_loc,
+ (Ast.CgAnt (_loc,
+ (mk_anti ~c: "class_sig_item" n s))),
+ csg) :
+ 'class_signature)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "csg" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "csg" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CgAnt (_loc,
+ (mk_anti ~c: "class_sig_item" n s)) :
+ 'class_signature)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_constraint :
+ 'type_constraint Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CgCtr (_loc, t1, t2) :
+ 'class_sig_item))));
+ ([ Gram.Skeyword "method";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t));
+ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label) _
+ (pf : 'opt_private) _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.CgVir (_loc, l, pf, t) :
+ 'class_sig_item))));
+ ([ Gram.Skeyword "method";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label)
+ (pf : 'opt_private) _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.CgMth (_loc, l, pf, t) :
+ 'class_sig_item))));
+ ([ Gram.Skeyword "method";
+ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (l : 'label)
+ (pf : 'opt_private) _ _ (_loc : Gram.Loc.t)
+ ->
+ (Ast.CgVir (_loc, l, pf, t) :
+ 'class_sig_item))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (value_val : 'value_val Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_mutable : 'opt_mutable Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_virtual : 'opt_virtual Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (l : 'label)
+ (mv : 'opt_virtual) (mf : 'opt_mutable) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CgVal (_loc, l, mf, mv, t) :
+ 'class_sig_item))));
+ ([ Gram.Skeyword "inherit";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type : 'class_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (cs : 'class_type) _ (_loc : Gram.Loc.t)
+ -> (Ast.CgInh (_loc, cs) : 'class_sig_item))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_sig_item_tag :
+ 'class_sig_item)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "csg" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "csg" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CgAnt (_loc,
+ (mk_anti ~c: "class_sig_item" n s)) :
+ 'class_sig_item)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (type_constraint : 'type_constraint Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "constraint" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (() : 'type_constraint))));
+ ([ Gram.Skeyword "type" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (() : 'type_constraint)))) ]) ]))
+ ());
+ Gram.extend
+ (class_description : 'class_description Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_info_for_class_type :
+ 'class_info_for_class_type Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_plus :
+ 'class_type_plus Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ct : 'class_type_plus) _
+ (ci : 'class_info_for_class_type)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtCol (_loc, ci, ct) :
+ 'class_description))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_type_tag :
+ 'class_description)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "typ" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "typ" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CtAnt (_loc,
+ (mk_anti ~c: "class_type" n s)) :
+ 'class_description)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (cd2 : 'class_description) _
+ (cd1 : 'class_description)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtAnd (_loc, cd1, cd2) :
+ 'class_description)))) ]) ]))
+ ());
+ Gram.extend
+ (class_type_declaration :
+ 'class_type_declaration Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_info_for_class_type :
+ 'class_info_for_class_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type : 'class_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ct : 'class_type) _
+ (ci : 'class_info_for_class_type)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtEq (_loc, ci, ct) :
+ 'class_type_declaration))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.class_type_tag :
+ 'class_type_declaration)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "typ" | "anti" | "list"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "typ" | "anti" | "list" as n)),
+ s) ->
+ (Ast.CtAnt (_loc,
+ (mk_anti ~c: "class_type" n s)) :
+ 'class_type_declaration)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (cd2 : 'class_type_declaration) _
+ (cd1 : 'class_type_declaration)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtAnd (_loc, cd1, cd2) :
+ 'class_type_declaration)))) ]) ]))
+ ());
+ Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (field_expr : 'field_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) ->
+ (b1 : 'field_expr_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (field_expr : 'field_expr Gram.Entry.t));
+ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t)
+ -> (b1 : 'field_expr_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (field_expr : 'field_expr Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (b2 : 'field_expr_list) _
+ (b1 : 'field_expr) (_loc : Gram.Loc.t) ->
+ (Ast.RbSem (_loc, b1, b2) :
+ 'field_expr_list)))) ]) ]))
+ ());
+ Gram.extend (field_expr : 'field_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (label : 'label Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterml
+ ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
+ "top") ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (l : 'label)
+ (_loc : Gram.Loc.t) ->
+ (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) :
+ 'field_expr))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.RbAnt (_loc,
+ (mk_anti ~c: "rec_binding" n s)) :
+ 'field_expr)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "bi" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "bi" | "anti" as n)), s)
+ ->
+ (Ast.RbAnt (_loc,
+ (mk_anti ~c: "rec_binding" n s)) :
+ 'field_expr)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (meth_list : 'meth_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (meth_decl : 'meth_decl Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (v : 'opt_dot_dot) (m : 'meth_decl)
+ (_loc : Gram.Loc.t) ->
+ ((m, v) : 'meth_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (meth_decl : 'meth_decl Gram.Entry.t));
+ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (v : 'opt_dot_dot) _ (m : 'meth_decl)
+ (_loc : Gram.Loc.t) ->
+ ((m, v) : 'meth_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (meth_decl : 'meth_decl Gram.Entry.t));
+ Gram.Skeyword ";"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl)
+ (_loc : Gram.Loc.t) ->
+ (((Ast.TySem (_loc, m, ml)), v) :
+ 'meth_list)))) ]) ]))
+ ());
+ Gram.extend (meth_decl : 'meth_decl Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (poly_type : 'poly_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'poly_type) _ (lab : 'a_LIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCol (_loc,
+ (Ast.TyId (_loc,
+ (Ast.IdLid (_loc, lab)))),
+ t) :
+ 'meth_decl))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'meth_decl)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp;" n s)) :
+ 'meth_decl)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'meth_decl)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) ->
+ (Ast.TyObj (_loc, (Ast.TyNil _loc), v) :
+ 'opt_meth_list))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (meth_list : 'meth_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((ml, v) : 'meth_list)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ]))
+ ());
+ Gram.extend (poly_type : 'poly_type Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'poly_type)))) ]) ]))
+ ());
+ Gram.extend (package_type : 'package_type Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'module_type) (_loc : Gram.Loc.t) ->
+ (p : 'package_type)))) ]) ]))
+ ());
+ Gram.extend (typevars : 'typevars Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Skeyword "'";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyQuo (_loc, i) : 'typevars))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'typevars)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'typevars)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'typevars) (t1 : 'typevars)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ]))
+ ());
+ Gram.extend
+ (unquoted_typevars : 'unquoted_typevars Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) (_loc : Gram.Loc.t) ->
+ (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) :
+ 'unquoted_typevars))));
+ ([ Gram.Stoken
+ (((function
+ | QUOTATION _ -> true
+ | _ -> false),
+ "QUOTATION _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | QUOTATION x ->
+ (Quotation.expand _loc x Quotation.
+ DynAst.ctyp_tag :
+ 'unquoted_typevars)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'unquoted_typevars)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'unquoted_typevars)
+ (t1 : 'unquoted_typevars)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyApp (_loc, t1, t2) :
+ 'unquoted_typevars)))) ]) ]))
+ ());
+ Gram.extend (row_field : 'row_field Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'row_field))));
+ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t));
+ Gram.Skeyword "of";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'amp_ctyp) _ (i : 'a_ident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) :
+ 'row_field))));
+ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t));
+ Gram.Skeyword "of"; Gram.Skeyword "&";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)),
+ t) :
+ 'row_field))));
+ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrn (_loc, i) : 'row_field))));
+ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'row_field) _ (t1 : 'row_field)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOr (_loc, t1, t2) : 'row_field))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp|" n s)) :
+ 'row_field)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'row_field)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) (_loc : Gram.Loc.t) ->
+ (t : 'amp_ctyp))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("list", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"list\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("list" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp&" n s)) :
+ 'amp_ctyp)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ]))
+ ());
+ Gram.extend (name_tags : 'name_tags Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrn (_loc, i) : 'name_tags))));
+ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (t2 : 'name_tags) (t1 : 'name_tags)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyApp (_loc, t1, t2) : 'name_tags))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "typ"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "typ" as n)), s) ->
+ (Ast.TyAnt (_loc,
+ (mk_anti ~c: "ctyp" n s)) :
+ 'name_tags)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (eq_expr : 'eq_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (fun i p -> Ast.PaOlb (_loc, i, p) :
+ 'eq_expr))));
+ ([ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) _ (_loc : Gram.Loc.t) ->
+ (fun i p -> Ast.PaOlbi (_loc, i, p, e) :
+ 'eq_expr)))) ]) ]))
+ ());
+ Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'patt) (_loc : Gram.Loc.t) ->
+ (p : 'patt_tcon))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (p : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ]))
+ ());
+ Gram.extend (ipatt : 'ipatt Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "?"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaOlbi (_loc, "", p, e) : 'ipatt))));
+ ([ Gram.Skeyword "?"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (p : 'ipatt_tcon) _ _
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaOlb (_loc, "", p) : 'ipatt))));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (Ast.PaOlb (_loc, (mk_anti n i),
+ (Ast.PaNil _loc)) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function | LIDENT _ -> true | _ -> false),
+ "LIDENT _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LIDENT i ->
+ (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)"));
+ Gram.Skeyword ":"; Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (eq_expr : 'eq_expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _
+ (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (f (mk_anti n i) p : 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function | OPTLABEL _ -> true | _ -> false),
+ "OPTLABEL _"));
+ Gram.Skeyword "(";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (ipatt_tcon : 'ipatt_tcon Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (eq_expr : 'eq_expr Gram.Entry.t));
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | OPTLABEL i -> (f i p : 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function | LIDENT _ -> true | _ -> false),
+ "LIDENT _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LIDENT i ->
+ (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (Ast.PaLab (_loc, (mk_anti n i),
+ (Ast.PaNil _loc)) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)"));
+ Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p : 'ipatt) _
+ (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), i) ->
+ (Ast.PaLab (_loc, (mk_anti n i), p) :
+ 'ipatt)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function | LABEL _ -> true | _ -> false),
+ "LABEL _"));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LABEL i ->
+ (Ast.PaLab (_loc, i, p) : 'ipatt)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (p : 'ipatt) (_loc : Gram.Loc.t) ->
+ (p : 'ipatt_tcon))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (t : 'ctyp) _ (p : 'ipatt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ]))
+ ());
+ Gram.extend (direction_flag : 'direction_flag Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("to" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"to\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("to" | "anti" as n)), s) ->
+ (Ast.DiAnt (mk_anti n s) :
+ 'direction_flag)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "downto" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.DiDownto : 'direction_flag))));
+ ([ Gram.Skeyword "to" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.DiTo : 'direction_flag)))) ]) ]))
+ ());
+ Gram.extend (opt_private : 'opt_private Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.PrNil : 'opt_private))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("private" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"private\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("private" | "anti" as n)), s)
+ ->
+ (Ast.PrAnt (mk_anti n s) :
+ 'opt_private)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "private" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.PrPrivate : 'opt_private)))) ]) ]))
+ ());
+ Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.MuNil : 'opt_mutable))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("mutable" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("mutable" | "anti" as n)), s)
+ ->
+ (Ast.MuAnt (mk_anti n s) :
+ 'opt_mutable)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "mutable" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.MuMutable : 'opt_mutable)))) ]) ]))
+ ());
+ Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.ViNil : 'opt_virtual))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("virtual" | "anti"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("virtual" | "anti" as n)), s)
+ ->
+ (Ast.ViAnt (mk_anti n s) :
+ 'opt_virtual)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "virtual" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.ViVirtual : 'opt_virtual)))) ]) ]))
+ ());
+ Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.RvNil : 'opt_dot_dot))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ((".." | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"..\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT (((".." | "anti" as n)), s) ->
+ (Ast.RvAnt (mk_anti n s) :
+ 'opt_dot_dot)
+ | _ -> assert false)));
+ ([ Gram.Skeyword ".." ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.RvRowVar : 'opt_dot_dot)))) ]) ]))
+ ());
+ Gram.extend (opt_rec : 'opt_rec Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.ReNil : 'opt_rec))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("rec" | "anti"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("rec" | "anti" as n)), s) ->
+ (Ast.ReAnt (mk_anti n s) : 'opt_rec)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "rec" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.ReRecursive : 'opt_rec)))) ]) ]))
+ ());
+ Gram.extend (opt_override : 'opt_override Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.OvNil : 'opt_override))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("!" | "override" | "anti"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("!" | "override" | "anti" as n)), s)
+ ->
+ (Ast.OvAnt (mk_anti n s) :
+ 'opt_override)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "!" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (Ast.OvOverride : 'opt_override)))) ]) ]))
+ ());
+ Gram.extend (opt_expr : 'opt_expr Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.ExNil _loc : 'opt_expr))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (_loc : Gram.Loc.t) ->
+ (e : 'opt_expr)))) ]) ]))
+ ());
+ Gram.extend (interf : 'interf Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | EOI -> true | _ -> false),
+ "EOI")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | EOI -> (([], None) : 'interf)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (sig_item : 'sig_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun ((sil, stopped) : 'interf) _
+ (si : 'sig_item) (_loc : Gram.Loc.t) ->
+ (((si :: sil), stopped) : 'interf))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_expr : 'opt_expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (([ Ast.SgDir (_loc, n, dp) ],
+ (stopped_at _loc)) : 'interf)))) ]) ]))
+ ());
+ Gram.extend (sig_items : 'sig_items Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Slist0
+ (Gram.srules sig_items
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (sig_item :
+ 'sig_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (sg : 'sig_item)
+ (_loc : Gram.Loc.t) ->
+ (sg : 'e__12)))) ]) ],
+ (Gram.Action.mk
+ (fun (l : 'e__12 list) (_loc : Gram.Loc.t) ->
+ (Ast.sgSem_of_list l : 'sig_items))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "sigi" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)"));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (sg : 'sig_items) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "sigi" | "anti" | "list" as n)),
+ s) ->
+ (Ast.SgSem (_loc,
+ (Ast.SgAnt (_loc,
+ (mk_anti n ~c: "sig_item" s))),
+ sg) :
+ 'sig_items)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "sigi" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "sigi" | "anti" | "list" as n)),
+ s) ->
+ (Ast.SgAnt (_loc,
+ (mk_anti n ~c: "sig_item" s)) :
+ 'sig_items)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (implem : 'implem Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | EOI -> true | _ -> false),
+ "EOI")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | EOI -> (([], None) : 'implem)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (str_item : 'str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun ((sil, stopped) : 'implem) _
+ (si : 'str_item) (_loc : Gram.Loc.t) ->
+ (((si :: sil), stopped) : 'implem))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_expr : 'opt_expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (([ Ast.StDir (_loc, n, dp) ],
+ (stopped_at _loc)) : 'implem)))) ]) ]))
+ ());
+ Gram.extend (str_items : 'str_items Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Slist0
+ (Gram.srules str_items
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (str_item :
+ 'str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (st : 'str_item)
+ (_loc : Gram.Loc.t) ->
+ (st : 'e__13)))) ]) ],
+ (Gram.Action.mk
+ (fun (l : 'e__13 list) (_loc : Gram.Loc.t) ->
+ (Ast.stSem_of_list l : 'str_items))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "stri" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)"));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (st : 'str_items) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "stri" | "anti" | "list" as n)),
+ s) ->
+ (Ast.StSem (_loc,
+ (Ast.StAnt (_loc,
+ (mk_anti n ~c: "str_item" s))),
+ st) :
+ 'str_items)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "stri" | "anti" | "list"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "stri" | "anti" | "list" as n)),
+ s) ->
+ (Ast.StAnt (_loc,
+ (mk_anti n ~c: "str_item" s)) :
+ 'str_items)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (top_phrase : 'top_phrase Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | EOI -> true | _ -> false),
+ "EOI")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | EOI -> (None : 'top_phrase)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (phrase : 'phrase Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ph : 'phrase) (_loc : Gram.Loc.t) ->
+ (Some ph : 'top_phrase)))) ]) ]))
+ ());
+ Gram.extend (use_file : 'use_file Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | EOI -> true | _ -> false),
+ "EOI")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | EOI -> (([], None) : 'use_file)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (str_item : 'str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun ((sil, stopped) : 'use_file) _
+ (si : 'str_item) (_loc : Gram.Loc.t) ->
+ (((si :: sil), stopped) : 'use_file))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_expr : 'opt_expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (([ Ast.StDir (_loc, n, dp) ],
+ (stopped_at _loc)) : 'use_file)))) ]) ]))
+ ());
+ Gram.extend (phrase : 'phrase Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (str_item : 'str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (st : 'str_item) (_loc : Gram.Loc.t) ->
+ (st : 'phrase))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_expr : 'opt_expr Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ]))
+ ());
+ Gram.extend (a_INT : 'a_INT Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | INT (_, _) -> true | _ -> false),
+ "INT (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | INT (_, s) -> (s : 'a_INT)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "int" | "`int"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "int" | "`int" as n)),
+ s) -> (mk_anti n s : 'a_INT)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | INT32 (_, _) -> true
+ | _ -> false),
+ "INT32 (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | INT32 (_, s) -> (s : 'a_INT32)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "int32" | "`int32"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "int32" | "`int32" as n)), s)
+ -> (mk_anti n s : 'a_INT32)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | INT64 (_, _) -> true
+ | _ -> false),
+ "INT64 (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | INT64 (_, s) -> (s : 'a_INT64)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "int64" | "`int64"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "int64" | "`int64" as n)), s)
+ -> (mk_anti n s : 'a_INT64)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | NATIVEINT (_, _) -> true
+ | _ -> false),
+ "NATIVEINT (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | NATIVEINT (_, s) -> (s : 'a_NATIVEINT)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT
+ (("" | "nativeint" | "`nativeint"), _)
+ -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "nativeint" | "`nativeint" as
+ n)),
+ s) -> (mk_anti n s : 'a_NATIVEINT)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | FLOAT (_, _) -> true
+ | _ -> false),
+ "FLOAT (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | FLOAT (_, s) -> (s : 'a_FLOAT)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "flo" | "`flo"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "flo" | "`flo" as n)),
+ s) -> (mk_anti n s : 'a_FLOAT)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | CHAR (_, _) -> true
+ | _ -> false),
+ "CHAR (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | CHAR (_, s) -> (s : 'a_CHAR)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "chr" | "`chr"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "chr" | "`chr" as n)),
+ s) -> (mk_anti n s : 'a_CHAR)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | UIDENT _ -> true | _ -> false),
+ "UIDENT _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | UIDENT s -> (s : 'a_UIDENT)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "uid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"uid\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "uid" as n)), s) ->
+ (mk_anti n s : 'a_UIDENT)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | LIDENT _ -> true | _ -> false),
+ "LIDENT _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LIDENT s -> (s : 'a_LIDENT)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "lid"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"lid\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "lid" as n)), s) ->
+ (mk_anti n s : 'a_LIDENT)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | LABEL _ -> true | _ -> false),
+ "LABEL _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | LABEL s -> (s : 'a_LABEL)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "~";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)"));
+ Gram.Skeyword ":" ],
+ (Gram.Action.mk
+ (fun _ (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), s) ->
+ (mk_anti n s : 'a_LABEL)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function | OPTLABEL _ -> true | _ -> false),
+ "OPTLABEL _")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | OPTLABEL s -> (s : 'a_OPTLABEL)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "?";
+ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)"));
+ Gram.Skeyword ":" ],
+ (Gram.Action.mk
+ (fun _ (__camlp4_0 : Gram.Token.t) _
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), s) ->
+ (mk_anti n s : 'a_OPTLABEL)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (a_STRING : 'a_STRING Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | STRING (_, _) -> true
+ | _ -> false),
+ "STRING (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | STRING (_, s) -> (s : 'a_STRING)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "str" | "`str"), _) ->
+ true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" | "str" | "`str" as n)),
+ s) -> (mk_anti n s : 'a_STRING)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (string_list : 'string_list Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Stoken
+ (((function
+ | STRING (_, _) -> true
+ | _ -> false),
+ "STRING (_, _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | STRING (_, x) ->
+ (Ast.LCons (x, Ast.LNil) :
+ 'string_list)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | STRING (_, _) -> true
+ | _ -> false),
+ "STRING (_, _)"));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (xs : 'string_list)
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | STRING (_, x) ->
+ (Ast.LCons (x, xs) : 'string_list)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "str_list"), _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"str_list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT (("" | "str_list"), s) ->
+ (Ast.LAnt (mk_anti "str_list" s) :
+ 'string_list)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (value_let : 'value_let Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "value" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (() : 'value_let)))) ]) ]))
+ ());
+ Gram.extend (value_val : 'value_val Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword "value" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) ->
+ (() : 'value_val)))) ]) ]))
+ ());
+ Gram.extend (semi : 'semi Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Skeyword ";" ],
+ (Gram.Action.mk
+ (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ]))
+ ());
+ Gram.extend (expr_quot : 'expr_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.ExNil _loc : 'expr_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e : 'expr) (_loc : Gram.Loc.t) ->
+ (e : 'expr_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_expr : 'sem_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e2 : 'sem_expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExSem (_loc, e1, e2) : 'expr_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Skeyword ",";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_expr : 'comma_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (e2 : 'comma_expr) _ (e1 : 'expr)
+ (_loc : Gram.Loc.t) ->
+ (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ]))
+ ());
+ Gram.extend (patt_quot : 'patt_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.PaNil _loc : 'patt_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'patt) (_loc : Gram.Loc.t) ->
+ (x : 'patt_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'patt) _ (x : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (let i =
+ match x with
+ | Ast.PaAnt (loc, s) ->
+ Ast.IdAnt (loc, s)
+ | p -> Ast.ident_of_patt p
+ in Ast.PaEq (_loc, i, y) : 'patt_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (sem_patt : 'sem_patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'sem_patt) _ (x : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaSem (_loc, x, y) : 'patt_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Skeyword ",";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_patt : 'comma_patt Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'comma_patt) _ (x : 'patt)
+ (_loc : Gram.Loc.t) ->
+ (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ]))
+ ());
+ Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.TyNil _loc : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (x : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "and";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_arg_list :
+ 'constructor_arg_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'constructor_arg_list) _
+ (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (Ast.TyAnd (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "&";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'amp_ctyp) _ (x : 'more_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyAmp (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "*";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (star_ctyp : 'star_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'star_ctyp) _ (x : 'more_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TySta (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_declaration_list :
+ 'label_declaration_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (z : 'label_declaration_list) _
+ (y : 'more_ctyp) _ (x : 'more_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)),
+ z) :
+ 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'more_ctyp) _ (x : 'more_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCol (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "of"; Gram.Skeyword "&";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (amp_ctyp : 'amp_ctyp Gram.Entry.t));
+ Gram.Skeyword "|";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (row_field : 'row_field Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _
+ (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (Ast.TyOr (_loc,
+ (Ast.TyOfAmp (_loc, x, y)), z) :
+ 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "of"; Gram.Skeyword "&";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "of";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_arg_list :
+ 'constructor_arg_list Gram.Entry.t));
+ Gram.Skeyword "|";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_declarations :
+ 'constructor_declarations Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (z : 'constructor_declarations) _
+ (y : 'constructor_arg_list) _
+ (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)),
+ z) :
+ 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "of";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_arg_list :
+ 'constructor_arg_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'constructor_arg_list) _
+ (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (Ast.TyOf (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword "|";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (constructor_declarations :
+ 'constructor_declarations Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'constructor_declarations) _
+ (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (Ast.TyOr (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword ";";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (label_declaration_list :
+ 'label_declaration_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'label_declaration_list) _
+ (x : 'more_ctyp) (_loc : Gram.Loc.t) ->
+ (Ast.TySem (_loc, x, y) : 'ctyp_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (more_ctyp : 'more_ctyp Gram.Entry.t));
+ Gram.Skeyword ",";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (y : 'comma_ctyp) _ (x : 'more_ctyp)
+ (_loc : Gram.Loc.t) ->
+ (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ]))
+ ());
+ Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (type_parameter :
+ 'type_parameter Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'type_parameter) (_loc : Gram.Loc.t)
+ -> (x : 'more_ctyp))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'ctyp) (_loc : Gram.Loc.t) ->
+ (x : 'more_ctyp))));
+ ([ Gram.Skeyword "`";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_ident : 'a_ident Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyVrn (_loc, x) : 'more_ctyp))));
+ ([ Gram.Skeyword "mutable"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) ->
+ (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ]))
+ ());
+ Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.StNil _loc : 'str_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (str_item : 'str_item Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (st : 'str_item) (_loc : Gram.Loc.t) ->
+ (st : 'str_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (str_item : 'str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (st2 : 'str_item_quot) _
+ (st1 : 'str_item) (_loc : Gram.Loc.t) ->
+ (match st2 with
+ | Ast.StNil _ -> st1
+ | _ -> Ast.StSem (_loc, st1, st2) :
+ 'str_item_quot))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_expr : 'opt_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (dp : 'opt_expr) (n : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ]))
+ ());
+ Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.SgNil _loc : 'sig_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (sig_item : 'sig_item Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (sg : 'sig_item) (_loc : Gram.Loc.t) ->
+ (sg : 'sig_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (sig_item : 'sig_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (sg2 : 'sig_item_quot) _
+ (sg1 : 'sig_item) (_loc : Gram.Loc.t) ->
+ (match sg2 with
+ | Ast.SgNil _ -> sg1
+ | _ -> Ast.SgSem (_loc, sg1, sg2) :
+ 'sig_item_quot))));
+ ([ Gram.Skeyword "#";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_expr : 'opt_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (dp : 'opt_expr) (n : 'a_LIDENT) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (module_type_quot : 'module_type_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.MtNil _loc : 'module_type_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'module_type) (_loc : Gram.Loc.t) ->
+ (x : 'module_type_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (module_expr_quot : 'module_expr_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.MeNil _loc : 'module_expr_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'module_expr) (_loc : Gram.Loc.t) ->
+ (x : 'module_expr_quot)))) ]) ]))
+ ());
+ Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.McNil _loc : 'match_case_quot))));
+ ([ Gram.Slist0sep
+ ((Gram.Snterm
+ (Gram.Entry.obj
+ (match_case0 :
+ 'match_case0 Gram.Entry.t))),
+ (Gram.Skeyword "|")) ],
+ (Gram.Action.mk
+ (fun (x : 'match_case0 list)
+ (_loc : Gram.Loc.t) ->
+ (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ]))
+ ());
+ Gram.extend (binding_quot : 'binding_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.BiNil _loc : 'binding_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (binding : 'binding Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'binding) (_loc : Gram.Loc.t) ->
+ (x : 'binding_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (rec_binding_quot : 'rec_binding_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.RbNil _loc : 'rec_binding_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (label_expr_list :
+ 'label_expr_list Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'label_expr_list)
+ (_loc : Gram.Loc.t) ->
+ (x : 'rec_binding_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (module_binding_quot : 'module_binding_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.MbNil _loc : 'module_binding_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (mt : 'module_type)
+ _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.MbColEq (_loc, m, mt, me) :
+ 'module_binding_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _ (m : 'a_UIDENT)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MbCol (_loc, m, mt) :
+ 'module_binding_quot))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)"));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t));
+ Gram.Skeyword "=";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_expr : 'module_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (me : 'module_expr) _ (mt : 'module_type)
+ _ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), m) ->
+ (Ast.MbColEq (_loc, (mk_anti n m), mt,
+ me) :
+ 'module_binding_quot)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)"));
+ Gram.Skeyword ":";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (module_type : 'module_type Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (mt : 'module_type) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), m) ->
+ (Ast.MbCol (_loc, (mk_anti n m), mt) :
+ 'module_binding_quot)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"\", _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("" as n)), s) ->
+ (Ast.MbAnt (_loc,
+ (mk_anti ~c: "module_binding" n s)) :
+ 'module_binding_quot)
+ | _ -> assert false)));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("module_binding" | "anti"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("module_binding" | "anti" as n)), s)
+ ->
+ (Ast.MbAnt (_loc,
+ (mk_anti ~c: "module_binding" n s)) :
+ 'module_binding_quot)
+ | _ -> assert false)));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (b2 : 'module_binding_quot) _
+ (b1 : 'module_binding_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.MbAnd (_loc, b1, b2) :
+ 'module_binding_quot)))) ]) ]))
+ ());
+ Gram.extend (ident_quot : 'ident_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ ((Some "apply"), None,
+ [ ([ Gram.Sself; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'ident_quot) (i : 'ident_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]);
+ ((Some "."), None,
+ [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (j : 'ident_quot) _ (i : 'ident_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]);
+ ((Some "simple"), None,
+ [ ([ Gram.Skeyword "("; Gram.Sself;
+ Gram.Skeyword ")" ],
+ (Gram.Action.mk
+ (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t)
+ -> (i : 'ident_quot))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)"));
+ Gram.Skeyword "."; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (i : 'ident_quot) _
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAcc (_loc,
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s))),
+ i) :
+ 'ident_quot)
+ | _ -> assert false)));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdLid (_loc, i) : 'ident_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+ (Ast.IdUid (_loc, i) : 'ident_quot))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT (("" | "id" | "anti" | "list"),
+ _) -> true
+ | _ -> false),
+ "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT
+ ((("" | "id" | "anti" | "list" as n)),
+ s) ->
+ (Ast.IdAnt (_loc,
+ (mk_anti ~c: "ident" n s)) :
+ 'ident_quot)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.CeNil _loc : 'class_expr_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_expr : 'class_expr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'class_expr) (_loc : Gram.Loc.t) ->
+ (x : 'class_expr_quot))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("virtual", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"virtual\", _)"));
+ Gram.Snterm
+ (Gram.Entry.obj (ident : 'ident Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_comma_ctyp :
+ 'opt_comma_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ot : 'opt_comma_ctyp) (i : 'ident)
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("virtual" as n)), s) ->
+ (let anti =
+ Ast.ViAnt
+ (mk_anti ~c: "class_expr" n s)
+ in Ast.CeCon (_loc, anti, i, ot) :
+ 'class_expr_quot)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_name_and_param :
+ 'class_name_and_param Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((i, ot) : 'class_name_and_param) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeCon (_loc, Ast.ViVirtual,
+ (Ast.IdLid (_loc, i)), ot) :
+ 'class_expr_quot))));
+ ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ce2 : 'class_expr_quot) _
+ (ce1 : 'class_expr_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeEq (_loc, ce1, ce2) :
+ 'class_expr_quot))));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ce2 : 'class_expr_quot) _
+ (ce1 : 'class_expr_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CeAnd (_loc, ce1, ce2) :
+ 'class_expr_quot)))) ]) ]))
+ ());
+ Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.CtNil _loc : 'class_type_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_type_plus :
+ 'class_type_plus Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'class_type_plus)
+ (_loc : Gram.Loc.t) ->
+ (x : 'class_type_quot))));
+ ([ Gram.Stoken
+ (((function
+ | ANTIQUOT ("virtual", _) -> true
+ | _ -> false),
+ "ANTIQUOT (\"virtual\", _)"));
+ Gram.Snterm
+ (Gram.Entry.obj (ident : 'ident Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_comma_ctyp :
+ 'opt_comma_ctyp Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (ot : 'opt_comma_ctyp) (i : 'ident)
+ (__camlp4_0 : Gram.Token.t)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | ANTIQUOT ((("virtual" as n)), s) ->
+ (let anti =
+ Ast.ViAnt
+ (mk_anti ~c: "class_type" n s)
+ in Ast.CtCon (_loc, anti, i, ot) :
+ 'class_type_quot)
+ | _ -> assert false)));
+ ([ Gram.Skeyword "virtual";
+ Gram.Snterm
+ (Gram.Entry.obj
+ (class_name_and_param :
+ 'class_name_and_param Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun ((i, ot) : 'class_name_and_param) _
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtCon (_loc, Ast.ViVirtual,
+ (Ast.IdLid (_loc, i)), ot) :
+ 'class_type_quot))));
+ ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ct2 : 'class_type_quot) _
+ (ct1 : 'class_type_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtCol (_loc, ct1, ct2) :
+ 'class_type_quot))));
+ ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ct2 : 'class_type_quot) _
+ (ct1 : 'class_type_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtEq (_loc, ct1, ct2) :
+ 'class_type_quot))));
+ ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ],
+ (Gram.Action.mk
+ (fun (ct2 : 'class_type_quot) _
+ (ct1 : 'class_type_quot)
+ (_loc : Gram.Loc.t) ->
+ (Ast.CtAnd (_loc, ct1, ct2) :
+ 'class_type_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (class_str_item_quot : 'class_str_item_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.CrNil _loc : 'class_str_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_str_item :
+ 'class_str_item Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'class_str_item) (_loc : Gram.Loc.t)
+ -> (x : 'class_str_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_str_item :
+ 'class_str_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (x2 : 'class_str_item_quot) _
+ (x1 : 'class_str_item) (_loc : Gram.Loc.t)
+ ->
+ (match x2 with
+ | Ast.CrNil _ -> x1
+ | _ -> Ast.CrSem (_loc, x1, x2) :
+ 'class_str_item_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.CgNil _loc : 'class_sig_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_sig_item :
+ 'class_sig_item Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'class_sig_item) (_loc : Gram.Loc.t)
+ -> (x : 'class_sig_item_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (class_sig_item :
+ 'class_sig_item Gram.Entry.t));
+ Gram.Snterm
+ (Gram.Entry.obj (semi : 'semi Gram.Entry.t));
+ Gram.Sself ],
+ (Gram.Action.mk
+ (fun (x2 : 'class_sig_item_quot) _
+ (x1 : 'class_sig_item) (_loc : Gram.Loc.t)
+ ->
+ (match x2 with
+ | Ast.CgNil _ -> x1
+ | _ -> Ast.CgSem (_loc, x1, x2) :
+ 'class_sig_item_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (with_constr_quot : 'with_constr_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([],
+ (Gram.Action.mk
+ (fun (_loc : Gram.Loc.t) ->
+ (Ast.WcNil _loc : 'with_constr_quot))));
+ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (with_constr : 'with_constr Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'with_constr) (_loc : Gram.Loc.t) ->
+ (x : 'with_constr_quot)))) ]) ]))
+ ());
+ Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_rec : 'opt_rec Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'opt_rec) (_loc : Gram.Loc.t) ->
+ (x : 'rec_flag_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (direction_flag_quot : 'direction_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (direction_flag :
+ 'direction_flag Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'direction_flag) (_loc : Gram.Loc.t)
+ -> (x : 'direction_flag_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_mutable : 'opt_mutable Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) ->
+ (x : 'mutable_flag_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (private_flag_quot : 'private_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_private : 'opt_private Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'opt_private) (_loc : Gram.Loc.t) ->
+ (x : 'private_flag_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_virtual : 'opt_virtual Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) ->
+ (x : 'virtual_flag_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) ->
+ (x : 'row_var_flag_quot)))) ]) ]))
+ ());
+ Gram.extend
+ (override_flag_quot : 'override_flag_quot Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj
+ (opt_override :
+ 'opt_override Gram.Entry.t)) ],
+ (Gram.Action.mk
+ (fun (x : 'opt_override) (_loc : Gram.Loc.t)
+ -> (x : 'override_flag_quot)))) ]) ]))
+ ());
+ Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (patt : 'patt Gram.Entry.t));
+ Gram.Stoken
+ (((function | EOI -> true | _ -> false),
+ "EOI")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) (x : 'patt)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | EOI -> (x : 'patt_eoi)
+ | _ -> assert false))) ]) ]))
+ ());
+ Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t)
+ ((fun () ->
+ (None,
+ [ (None, None,
+ [ ([ Gram.Snterm
+ (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
+ Gram.Stoken
+ (((function | EOI -> true | _ -> false),
+ "EOI")) ],
+ (Gram.Action.mk
+ (fun (__camlp4_0 : Gram.Token.t) (x : 'expr)
+ (_loc : Gram.Loc.t) ->
+ match __camlp4_0 with
+ | EOI -> (x : 'expr_eoi)
+ | _ -> assert false))) ]) ]))
+ ()))
+ in apply ()
end
Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
Gram.Skeyword "]" ];
true)
- with | Not_found -> false
+ with | Struct.Grammar.Delete.Rule_not_found _ -> false
let comprehension_or_sem_expr_for_list =
Gram.Entry.mk "comprehension_or_sem_expr_for_list"
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: camlp4.1.tpl 12800 2012-07-30 18:59:07Z doligez $
-.\"
.TH CAMLP4 1 "" "INRIA"
.SH NAME
camlp4 - Pre-Precessor-Pretty-Printer for OCaml
# #
#########################################################################
-# $Id: Makefile-templ 12027 2012-01-16 09:05:37Z frisch $
-
### Compile-time configuration
########## General configuration
# #
#########################################################################
-# $Id: Makefile.mingw 12461 2012-05-15 14:18:16Z frisch $
-
# Configuration for Windows, Mingw compiler
######### General configuration
PTHREAD_LINK=
X11_INCLUDES=
X11_LINK=
-DBM_INCLUDES=
-DBM_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
SHAREDCCCOMPOPTS=
NATIVECCPROFOPTS=
NATIVECCRPATH=
ASM=$(TOOLPREF)as
-ASPP=gcc
+ASPP=$(TOOLPREF)gcc -c
ASPPPROFFLAGS=
PROFILING=noprof
DYNLINKOPTS=
NATIVECCLINKOPTS=
### Build partially-linked object file
-PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o'
+PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o # must have a space after '-o'
############# Configuration for the contributed libraries
MAKEREC=$(MAKE) -f Makefile.nt
MAKECMD=$(MAKE)
+
+############# for the testsuite makefiles
+#ml let topdir = "" and wintopdir = "";;
+OTOPDIR=$(WINTOPDIR)
+CTOPDIR=$(TOPDIR)
+CYGPATH=cygpath -m
+DIFF=diff -q --strip-trailing-cr
+CANKILL=false
+SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
# #
#########################################################################
-# $Id: Makefile.mingw 11319 2011-12-16 17:02:48Z xleroy $
-
# Configuration for Windows, Mingw compiler
######### General configuration
PTHREAD_LINK=
X11_INCLUDES=
X11_LINK=
-DBM_INCLUDES=
-DBM_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
SHAREDCCCOMPOPTS=
NATIVECCPROFOPTS=
NATIVECCRPATH=
ASM=$(TOOLPREF)as
-ASPP=gcc
+ASPP=$(TOOLPREF)gcc -c
ASPPPROFFLAGS=
PROFILING=noprof
DYNLINKOPTS=
NATIVECCLINKOPTS=
### Build partially-linked object file
-PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o'
+PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o # must have a space after '-o'
############# Configuration for the contributed libraries
MAKEREC=$(MAKE) -f Makefile.nt
MAKECMD=$(MAKE)
+
+############# for the testsuite makefiles
+#ml let topdir = "" and wintopdir = "";;
+OTOPDIR=$(WINTOPDIR)
+CTOPDIR=$(TOPDIR)
+CYGPATH=cygpath -m
+DIFF=diff -q --strip-trailing-cr
+CANKILL=false
+SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
# #
#########################################################################
-# $Id: Makefile.msvc 12461 2012-05-15 14:18:16Z frisch $
-
# Configuration for Windows, Visual C++ compiler
######### General configuration
PTHREAD_LINK=
X11_INCLUDES=
X11_LINK=
-DBM_INCLUDES=
-DBM_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
SHAREDCCCOMPOPTS=
MAKEREC=$(MAKE) -f Makefile.nt
MAKECMD=$(MAKE)
+
+############# for the testsuite makefiles
+#ml let topdir = "" and wintopdir = "";;
+OTOPDIR=$(WINTOPDIR)
+CTOPDIR=$(WINTOPDIR)
+CYGPATH=cygpath -m
+DIFF=diff -q --strip-trailing-cr
+CANKILL=false
+FIND=/usr/bin/find
+SORT=/usr/bin/sort
+SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
# #
#########################################################################
-# $Id: Makefile.msvc64 12461 2012-05-15 14:18:16Z frisch $
-
# Configuration for Windows, Visual C++ compiler
######### General configuration
PTHREAD_LINK=
X11_INCLUDES=
X11_LINK=
-DBM_INCLUDES=
-DBM_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
SHAREDCCCOMPOPTS=
NATIVECCLINKOPTS=
### Build partially-linked object file
-PACKLD=link /lib /nologo /machine:AMD64 /out:# there must be no space after this '/out:'
+PACKLD=link /lib /nologo /machine:AMD64 /out:# must have no space after '/out:'
############# Configuration for camlp4
MAKEREC=$(MAKE) -f Makefile.nt
MAKECMD=$(MAKE)
+
+############# for the testsuite makefiles
+#ml let topdir = "" and wintopdir = "";;
+OTOPDIR=$(WINTOPDIR)
+CTOPDIR=$(WINTOPDIR)
+CYGPATH=cygpath -m
+DIFF=diff -q --strip-trailing-cr
+CANKILL=false
+FIND=/usr/bin/find
+SORT=/usr/bin/sort
+SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
/* */
/***********************************************************************/
-/* $Id: align.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <signal.h>
#include <setjmp.h>
/* */
/***********************************************************************/
-/* $Id: async_io.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <fcntl.h>
#include <signal.h>
/* */
/***********************************************************************/
-/* $Id: bytecopy.c 11156 2011-07-27 14:17:02Z doligez $ */
-
char buffer[27];
#ifdef reverse
/* */
/***********************************************************************/
-/* $Id: dblalign.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <signal.h>
#include <setjmp.h>
/* */
/***********************************************************************/
-/* $Id: divmod.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Test semantics of division and modulus for negative arguments */
long div4[] =
/* */
/***********************************************************************/
-/* $Id: elf.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
int main(int argc, char ** argv)
/* */
/***********************************************************************/
-/* $Id: endian.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "m.h"
#ifndef ARCH_SIXTYFOUR
/* */
/***********************************************************************/
-/* $Id$ */
-
#include <math.h>
volatile double x;
/* */
/***********************************************************************/
-/* $Id: getgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <limits.h>
/* */
/***********************************************************************/
-/* $Id: gethostbyaddr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef _REENTRANT
/* This helps detection on Digital Unix... */
#define _REENTRANT
/* */
/***********************************************************************/
-/* $Id: gethostbyname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#ifndef _REENTRANT
/* This helps detection on Digital Unix... */
#define _REENTRANT
/* */
/***********************************************************************/
-/* $Id: ia32sse2.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Test whether IA32 assembler supports SSE2 instructions */
int main()
/* */
/***********************************************************************/
-/* $Id: initgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <sys/types.h>
/* */
/***********************************************************************/
-/* $Id: int64align.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <signal.h>
#include <setjmp.h>
/* */
/***********************************************************************/
-/* $Id: longlong.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: schar.c 11156 2011-07-27 14:17:02Z doligez $ */
-
char foo[]="\377";
int main(int argc, char ** argv)
/* */
/***********************************************************************/
-/* $Id: schar2.c 11156 2011-07-27 14:17:02Z doligez $ */
-
signed char foo[]="\377";
int main(int argc, char ** argv)
/* */
/***********************************************************************/
-/* $Id: setgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <sys/types.h>
/* */
/***********************************************************************/
-/* $Id: sighandler.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <signal.h>
int main(void)
/* */
/***********************************************************************/
-/* $Id: signals.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* To determine the semantics of signal handlers
(System V: signal is reset to default behavior on entrance to the handler
BSD: signal handler remains active). */
/* */
/***********************************************************************/
-/* $Id: sizes.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
int main(int argc, char **argv)
/* */
/***********************************************************************/
-/* $Id: stackov.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <signal.h>
#include <sys/resource.h>
/* */
/***********************************************************************/
-/* $Id: tclversion.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <tcl.h>
#include <tk.h>
#!/bin/sh
+
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
+# #
+# Copyright 2012 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the GNU Library General Public License, with #
+# the special exception on linking described in file ../../LICENSE. #
+# #
+#########################################################################
+
if test "$verbose" = yes; then
echo "tryassemble: $aspp -o tst $*" >&2
$aspp -o tst $* || exit 100
/* */
/***********************************************************************/
-/* $Id: m-nt.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Machine configuration, Intel x86 processors, Win32,
Visual C++ or Mingw compiler */
/* */
/***********************************************************************/
-/* $Id: m-templ.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Processor dependencies */
#define ARCH_SIXTYFOUR
/* */
/***********************************************************************/
-/* $Id: s-nt.h 12030 2012-01-16 10:23:51Z frisch $ */
-
/* Operating system dependencies, Intel x86 processors, Windows NT */
#define OCAML_OS_TYPE "Win32"
#define HAS_PUTENV
#define HAS_LOCALE
#define HAS_BROKEN_PRINTF
+#define HAS_IPV6
/* */
/***********************************************************************/
-/* $Id: s-templ.h 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Operating system and standard library dependencies. */
/* 0. Operating system type string. */
# #
#########################################################################
-# $Id: configure 12645 2012-06-26 15:33:50Z doligez $
-
configure_options="$*"
prefix=/usr/local
bindir=''
gcc_warnings="-Wall"
partialld="ld -r"
withcamlp4=camlp4
+with_frame_pointers=false
+with_cfi=true
# Try to turn internationalization off, can cause config.guess to malfunction!
unset LANG
debugruntime=runtimed;;
-no-camlp4|--no-camlp4)
withcamlp4="";;
+ -with-frame-pointers|--with-frame-pointers)
+ with_frame_pointers=true;;
+ -no-cfi|--no-cfi)
+ with_cfi=false;;
*) echo "Unknown option \"$1\"." 1>&2; exit 2;;
esac
shift
*,*-*-darwin*)
bytecccompopts="-fno-defer-pop $gcc_warnings"
mathlib=""
+ mkexe="$mkexe -Wl,-no_compact_unwind"
# Tell gcc that we can use 32-bit code addresses for threaded code
# unless we are compiled for a shared library (-fPIC option)
echo "#ifndef __PIC__" >> m.h
1) echo "Doubles must be doubleword-aligned."
echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
*) echo "Something went wrong during alignment determination for doubles."
- echo "I'm going to assume this architecture has alignment constraints over doubles."
+ echo "We will assume alignment constraints over doubles."
echo "That's a safe bet: OCaml will work even if"
- echo "this architecture has actually no alignment constraints."
+ echo "this architecture actually has no alignment constraints."
echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
esac;;
esac
echo "#undef ARCH_ALIGN_INT64" >> m.h;;
1) echo "64-bit integers must be doubleword-aligned."
echo "#define ARCH_ALIGN_INT64" >> m.h;;
- *) echo "Something went wrong during alignment determination for 64-bit integers."
- echo "I'm going to assume this architecture has alignment constraints."
- echo "That's a safe bet: OCaml will work even if"
+ *) echo "Something went wrong during alignment determination for 64-bit"
+ echo "integers. I'm going to assume this architecture has alignment"
+ echo "constraints. That's a safe bet: OCaml will work even if"
echo "this architecture has actually no alignment constraints."
echo "#define ARCH_ALIGN_INT64" >> m.h;;
esac
sh ./runtest divmod.c
case $? in
- 0) echo "Native division and modulus have round-towards-zero semantics, will use them."
+ 0) echo "Native division and modulus have round-towards-zero semantics,"
+ echo "will use them."
echo "#undef NONSTANDARD_DIV_MOD" >> m.h;;
- 1) echo "Native division and modulus do not have round-towards-zero semantics, will use software emulation."
+ 1) echo "Native division and modulus do not have round-towards-zero"
+ echo "semantics, will use software emulation."
echo "#define NONSTANDARD_DIV_MOD" >> m.h;;
- *) echo "Something went wrong while checking native division and modulus, please report it."
+ *) echo "Something went wrong while checking native division and modulus,"
+ echo "please report it at http://http://caml.inria.fr/mantis/"
echo "#define NONSTANDARD_DIV_MOD" >> m.h;;
esac
mksharedlib="$flexlink"
mkmaindll="$flexlink -maindll"
shared_libraries_supported=true;;
- *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*)
+ *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*)
sharedcccompopts="-fPIC"
mksharedlib="$bytecc -shared"
bytecclinkopts="$bytecclinkopts -Wl,-E"
dl_needs_underscore=false
shared_libraries_supported=true;;
*-apple-darwin*)
- mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress"
+ mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -Wl,-no_compact_unwind"
bytecccompopts="$dl_defs $bytecccompopts"
dl_needs_underscore=false
shared_libraries_supported=true;;
i[3456]86-*-gnu*) arch=i386; system=gnu;;
powerpc*-*-linux*) arch=power; model=ppc; system=elf;;
powerpc-*-netbsd*) arch=power; model=ppc; system=elf;;
+ powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;;
powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;;
powerpc-*-darwin*) arch=power; system=rhapsody
- if $arch64; then model=ppc64; else model=ppc; fi;;
+ if $arch64;then model=ppc64;else model=ppc;fi;;
+ armv6*-*-linux-gnueabihf) arch=arm; model=armv6; system=linux_eabihf;;
arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;;
armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;;
armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;;
nativecccompopts=''
nativecclinkopts=''
+# FIXME the naming of nativecclinkopts is broken: these are options for
+# ld (for shared libs), not for cc
nativeccrpath="$byteccrpath"
case "$arch,$nativecc,$system,$host_type" in
asppprofflags='-DPROFILING'
case "$arch,$model,$system" in
- amd64,*,macosx) as='as -arch x86_64'
- aspp='gcc -arch x86_64 -c';;
+ amd64,*,macosx) if ./searchpath clang; then
+ as='clang -arch x86_64 -c'
+ aspp='clang -arch x86_64 -c'
+ else
+ as='as -arch x86_64'
+ aspp='gcc -arch x86_64 -c'
+ fi;;
amd64,*,solaris) as='as --64'
aspp='gcc -m64 -c';;
amd64,*,*) as='as'
aspp='gcc -c';;
power,*,elf) as='as -u -m ppc'
aspp='gcc -c';;
- power,*,bsd) as='as'
+ power,*,bsd*) as='as'
aspp='gcc -c';;
power,*,rhapsody) as="as -arch $model"
aspp="$bytecc -c";;
echo "SHARPBANGSCRIPTS=false" >> Makefile;;
*-*-cygwin*)
echo "We won't use it, though, because of conflicts with .exe extension"
- echo "under Cygwin"
+ echo " under Cygwin"
echo "SHARPBANGSCRIPTS=false" >> Makefile;;
*)
echo "SHARPBANGSCRIPTS=true" >> Makefile;;
for tk_incs in \
"-I/usr/local/include" \
"-I/usr/include" \
+ "-I/usr/local/include/tcl8.6 -I/usr/local/include/tk8.6" \
+ "-I/usr/include/tcl8.6 -I/usr/include/tk8.6" \
"-I/usr/local/include/tcl8.5 -I/usr/local/include/tk8.5" \
"-I/usr/include/tcl8.5 -I/usr/include/tk8.5" \
"-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" \
if test -n "$tcl_version" && test "x$tcl_version" != "xnone"; then
echo "tcl.h and tk.h version $tcl_version found with \"$tk_defs\"."
case $tcl_version in
+ 8.6) tclmaj=8 tclmin=6 tkmaj=8 tkmin=6 ;;
8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;;
8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;;
8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;;
export as aspp
-if sh ./tryassemble cfi.S; then
+if ! $with_cfi; then
+ echo "CFI support: disabled by command-line option -no-cfi"
+elif sh ./tryassemble cfi.S; then
echo "#define ASM_CFI_SUPPORTED" >> m.h
asm_cfi_supported=true
echo "Assembler supports CFI"
echo "Assembler does not support CFI"
fi
+if test "$with_frame_pointers" = "true"; then
+ case "$host,$cc" in
+ x86_64-*-linux*,gcc*)
+ nativecccompopts="$nativecccompopts -g -fno-omit-frame-pointer"
+ bytecccompopts="$bytecccompopts -g -fno-omit-frame-pointer"
+ nativecclinkopts="$nativecclinkopts -g"
+ echo "#define WITH_FRAME_POINTERS" >> m.h
+ ;;
+ *) echo "Unsupported architecture with frame pointers" 1>&2; exit 2;;
+ esac
+
+fi
+
+
# Final twiddling of compiler options to work around known bugs
nativeccprofopts="$nativecccompopts"
echo "RUNTIMED=${debugruntime}" >>Makefile
echo "CAMLP4=${withcamlp4}" >>Makefile
echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile
+echo "WITH_FRAME_POINTERS=$with_frame_pointers" >> Makefile
+if [ "$ostype" = Cygwin ]; then
+ echo "DIFF=diff -q --strip-trailing-cr" >>Makefile
+fi
+
rm -f tst hasgot.c
rm -f ../m.h ../s.h ../Makefile
else
echo " assembler supports CFI ... no"
fi
+ if test "$with_frame_pointers" = "true"; then
+ echo " with frame pointers....... yes"
+ else
+ echo " with frame pointers....... no"
+ fi
echo " native dynlink ........... $natdynlink"
if test "$profiling" = "prof"; then
echo " profiling with gprof ..... supported"
debugcom.cmi : primitives.cmi
debugger_config.cmi :
dynlink.cmi :
-envaux.cmi : ../typing/subst.cmi ../typing/path.cmi ../bytecomp/instruct.cmi \
- ../typing/env.cmi
eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \
../typing/env.cmi debugcom.cmi
parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/longident.cmi \
../parsing/location.cmi loadprinter.cmi lexer.cmi int64ops.cmi \
../bytecomp/instruct.cmi input_handling.cmi history.cmi frames.cmi \
- events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \
- ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \
- command_line.cmi
+ events.cmi eval.cmi ../typing/envaux.cmi ../typing/env.cmi \
+ debugger_config.cmi debugcom.cmi ../typing/ctype.cmi ../utils/config.cmi \
+ checkpoints.cmi breakpoints.cmi command_line.cmi
command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \
show_source.cmx show_information.cmx question.cmx program_management.cmx \
parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/longident.cmx \
../parsing/location.cmx loadprinter.cmx lexer.cmx int64ops.cmx \
../bytecomp/instruct.cmx input_handling.cmx history.cmx frames.cmx \
- events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \
- ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \
- command_line.cmi
+ events.cmx eval.cmx ../typing/envaux.cmx ../typing/env.cmx \
+ debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx \
+ checkpoints.cmx breakpoints.cmx command_line.cmi
debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \
input_handling.cmi debugcom.cmi
debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \
../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \
../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \
../typing/cmi_format.cmx dynlink.cmi
-envaux.cmo : ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \
- ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \
- ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi
-envaux.cmx : ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \
- ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \
- ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi
eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \
printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \
../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \
../typing/env.cmx debugger_config.cmx ../utils/config.cmx \
command_line.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \
checkpoints.cmx
-parameters.cmo : primitives.cmi envaux.cmi debugger_config.cmi \
+parameters.cmo : primitives.cmi ../typing/envaux.cmi debugger_config.cmi \
../utils/config.cmi parameters.cmi
-parameters.cmx : primitives.cmx envaux.cmx debugger_config.cmx \
+parameters.cmx : primitives.cmx ../typing/envaux.cmx debugger_config.cmx \
../utils/config.cmx parameters.cmi
parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \
input_handling.cmi parser.cmi
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
UNIXDIR=../otherlibs/unix
include Makefile.shared
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
UNIXDIR=../otherlibs/win32unix
include Makefile.shared
# #
#########################################################################
-# $Id: Makefile.shared 12526 2012-05-31 12:41:49Z lefessan $
-
include ../config/Makefile
CAMLC=../ocamlcomp.sh
../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
../typing/subst.cmo ../typing/predef.cmo \
- ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo ../typing/oprint.cmo \
+ ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo \
+ ../typing/oprint.cmo \
../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \
+ ../typing/envaux.cmo \
../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \
../bytecomp/opcodes.cmo \
primitives.cmo \
unix_tools.cmo \
debugger_config.cmo \
- envaux.cmo \
parameters.cmo \
lexer.cmo \
input_handling.cmo \
(* *)
(***********************************************************************)
-(* $Id: breakpoints.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(******************************* Breakpoints ***************************)
open Checkpoints
[]
end
@
- List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints)
+ List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc)
+ !breakpoints)
(* Is there a breakpoint at `pc' ? *)
let breakpoint_at_pc pc =
incr breakpoint_number;
insert_position event.ev_pos;
breakpoints := (!breakpoint_number, event) :: !breakpoints);
- printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos
+ printf "Breakpoint %d at %d: %s" !breakpoint_number event.ev_pos
(Pos.get_desc event);
print_newline ()
(function () ->
breakpoints := List.remove_assoc number !breakpoints;
remove_position pos;
- printf "Removed breakpoint %d at %d : %s" number ev.ev_pos
+ printf "Removed breakpoint %d at %d: %s" number ev.ev_pos
(Pos.get_desc ev);
print_newline ()
)
(* *)
(***********************************************************************)
-(* $Id: breakpoints.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(******************************* Breakpoints ***************************)
open Primitives
(* *)
(***********************************************************************)
-(* $Id: checkpoints.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*************************** Checkpoints *******************************)
open Int64ops
(* *)
(***********************************************************************)
-(* $Id: checkpoints.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(***************************** Checkpoints *****************************)
open Primitives
(* *)
(***********************************************************************)
-(* $Id: command_line.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(************************ Reading and executing commands ***************)
open Int64ops
new_breakpoint (any_event_at_pc pc)
with
| Not_found ->
- eprintf "Can't add breakpoint at pc %i : no event there.@." pc;
+ eprintf "Can't add breakpoint at pc %i: no event there.@." pc;
raise Toplevel
let add_breakpoint_after_pc pc =
with
| Parsing.Parse_error ->
error "Syntax error."
+ | Failure "int_of_string" ->
+ error "Integer overflow"
let line_loop ppf line_buffer =
resume_user_input ();
| Exit ->
stop_user_input ()
(* | Sys_error s ->
- error ("System error : " ^ s) *)
+ error ("System error: " ^ s) *)
(** Instructions. **)
let instr_cd ppf lexbuf =
else begin
let new_directory' = List.rev new_directory in
match new_directory' with
- | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 ->
+ | mdl :: for_keyw :: tl
+ when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 ->
List.iter (function x -> add_path_for mdl (expand_path x)) tl
| _ ->
List.iter (function x -> add_path (expand_path x)) new_directory'
end;
let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
- fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path;
+ fprintf ppf "@[<2>Directories: %a@]@." print_dirs !Config.load_path;
Hashtbl.iter
(fun mdl dirs ->
- fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs)
+ fprintf ppf "@[<2>Source directories for %s: %a@]@." mdl print_dirs
+ dirs)
Debugger_config.load_path_for
let instr_kill ppf lexbuf =
let print_variable_list ppf =
let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in
- fprintf ppf "List of variables :%a@." pr_vars !variable_list
+ fprintf ppf "List of variables: %a@." pr_vars !variable_list
let print_info_list ppf =
let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in
- fprintf ppf "List of info commands :%a@." pr_infos !info_list
+ fprintf ppf "List of info commands: %a@." pr_infos !info_list
let instr_complete ppf lexbuf =
let ppf = Format.err_formatter in
| Some x ->
let print_help nm hlp =
eol lexbuf;
- fprintf ppf "%s : %s@." nm hlp in
+ fprintf ppf "%s: %s@." nm hlp in
begin match matching_instructions x with
| [] ->
eol lexbuf;
print_help i.instr_name i.instr_help
| l ->
eol lexbuf;
- fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l
+ fprintf ppf "Ambiguous command \"%s\": %a@." x pr_instrs l
end
| None ->
- fprintf ppf "List of commands : %a@." pr_instrs !instruction_list
+ fprintf ppf "List of commands: %a@." pr_instrs !instruction_list
(* Printing values *)
Eval.report_error ppf msg;
raise Toplevel
+let env_of_event =
+ function
+ None -> Env.empty
+ | Some ev ->
+ Envaux.env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst
+
let print_command depth ppf lexbuf =
let exprs = expression_list_eol Lexer.lexeme lexbuf in
ensure_loaded ();
let env =
try
- Envaux.env_of_event !selected_event
+ env_of_event !selected_event
with
| Envaux.Error msg ->
Envaux.report_error ppf msg;
(function ppf ->
List.iter
(function {var_name = nm; var_action = (_, funct)} ->
- fprintf ppf "%s : " nm;
+ fprintf ppf "%s: " nm;
funct ppf)
!variable_list)
| BA_function expr -> (* break FUNCTION *)
let env =
try
- Envaux.env_of_event !selected_event
+ env_of_event !selected_event
with
| Envaux.Error msg ->
Envaux.report_error ppf msg;
raise Toplevel)
| BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *)
try
- new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position)
+ new_breakpoint
+ (event_near_pos (convert_module (module_of_longident mdle))
+ position)
with
| Not_found ->
eprintf "Can't find any event there.@."
let pr_modules ppf mods =
let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in
- fprintf ppf "Used modules :@.%a@?" pr_mods mods
+ fprintf ppf "Used modules: @.%a@?" pr_mods mods
let info_modules ppf lexbuf =
eol lexbuf;
ensure_loaded ();
pr_modules ppf !modules
(********
- print_endline "Opened modules :";
+ print_endline "Opened modules: ";
if !opened_modules_names = [] then
print_endline "(no module opened)."
else
- (List.iter (function x -> print_string x; print_space) !opened_modules_names;
+ (List.iter (function x -> print_string x;print_space) !opened_modules_names;
print_newline ())
*********)
let info_events ppf lexbuf =
ensure_loaded ();
- let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in
- print_endline ("Module : " ^ mdle);
+ let mdle =
+ convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf))
+ in
+ print_endline ("Module: " ^ mdle);
print_endline " Address Characters Kind Repr.";
List.iter
(function ev ->
var_action = loading_mode_variable ppf;
var_help =
"mode of loading.\n\
-It can be either :\n\
- direct : the program is directly called by the debugger.\n\
- runtime : the debugger execute `ocamlrun programname arguments'.\n\
- manual : the program is not launched by the debugger,\n\
+It can be either:\n\
+ direct: the program is directly called by the debugger.\n\
+ runtime: the debugger execute `ocamlrun programname arguments'.\n\
+ manual: the program is not launched by the debugger,\n\
but manually by the user." };
{ var_name = "processcount";
var_action = integer_variable false 1 "Must be >= 1."
var_help =
"process to follow after forking.\n\
It can be either :
- child : the newly created process.\n\
- parent : the process that called fork.\n" }];
+ child: the newly created process.\n\
+ parent: the process that called fork.\n" }];
info_list :=
(* info name, function, help *)
(* *)
(***********************************************************************)
-(* $Id: command_line.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(************************ Reading and executing commands ***************)
open Lexing;;
(* *)
(***********************************************************************)
-(* $Id: debugcom.ml 12184 2012-02-23 19:54:44Z doligez $ *)
-
(* Low-level communication with the debuggee *)
open Int64ops
(* *)
(***********************************************************************)
-(* $Id: debugcom.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Low-level communication with the debuggee *)
type execution_summary =
(* *)
(***********************************************************************)
-(* $Id: debugger_config.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
(**************************** Configuration file ***********************)
open Int64ops
(* *)
(***********************************************************************)
-(* $Id: debugger_config.mli 12210 2012-03-08 19:52:03Z doligez $ *)
-
(********************** Configuration file *****************************)
exception Toplevel
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* OCaml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id: envaux.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
-open Misc
-open Types
-open Env
-
-type error =
- Module_not_found of Path.t
-
-exception Error of error
-
-let env_cache =
- (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
-
-let reset_cache () =
- Hashtbl.clear env_cache;
- Env.reset_cache()
-
-let extract_sig env mty =
- match Mtype.scrape env mty with
- Mty_signature sg -> sg
- | _ -> fatal_error "Envaux.extract_sig"
-
-let rec env_from_summary sum subst =
- try
- Hashtbl.find env_cache (sum, subst)
- with Not_found ->
- let env =
- match sum with
- Env_empty ->
- Env.empty
- | Env_value(s, id, desc) ->
- Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst)
- | Env_type(s, id, desc) ->
- Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst)
- | Env_exception(s, id, desc) ->
- Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst)
- | Env_module(s, id, desc) ->
- Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst)
- | Env_modtype(s, id, desc) ->
- Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst)
- | Env_class(s, id, desc) ->
- Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst)
- | Env_cltype (s, id, desc) ->
- Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst)
- | Env_open(s, path) ->
- let env = env_from_summary s subst in
- let path' = Subst.module_path subst path in
- let mty =
- try
- Env.find_module path' env
- with Not_found ->
- raise (Error (Module_not_found path'))
- in
- Env.open_signature path' (extract_sig env mty) env
- in
- Hashtbl.add env_cache (sum, subst) env;
- env
-
-let env_of_event =
- function
- None -> Env.empty
- | Some ev -> env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
- | Module_not_found p ->
- fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* OCaml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id: envaux.mli 12700 2012-07-11 17:23:37Z lefessan $ *)
-
-open Format
-
-(* Convert environment summaries to environments *)
-
-val env_from_summary : Env.summary -> Subst.t -> Env.t
-val env_of_event: Instruct.debug_event option -> Env.t
-
-(* Empty the environment caches. To be called when load_path changes. *)
-
-val reset_cache: unit -> unit
-
-(* Error report *)
-
-type error =
- Module_not_found of Path.t
-
-exception Error of error
-
-val report_error: formatter -> error -> unit
(* *)
(***********************************************************************)
-(* $Id: eval.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Misc
open Path
open Instruct
end
| E_result ->
begin match event with
- Some {ev_kind = Event_after ty; ev_typsubst = subst} when !Frames.current_frame = 0 ->
+ Some {ev_kind = Event_after ty; ev_typsubst = subst}
+ when !Frames.current_frame = 0 ->
(Debugcom.Remote_value.accu(), Subst.type_expr subst ty)
| _ ->
raise(Error(No_result))
pos len Printtyp.type_expr ty
| Array_index(len, pos) ->
fprintf ppf
- "@[Cannot extract element number %i from an array of length %i@]@." pos len
+ "@[Cannot extract element number %i from an array of length %i@]@."
+ pos len
| List_index(len, pos) ->
fprintf ppf
- "@[Cannot extract element number %i from a list of length %i@]@." pos len
+ "@[Cannot extract element number %i from a list of length %i@]@."
+ pos len
| String_index(s, len, pos) ->
fprintf ppf
"@[Cannot extract character number %i@ \
(* *)
(***********************************************************************)
-(* $Id: eval.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Types
open Parser_aux
open Format
(* *)
(***********************************************************************)
-(* $Id: events.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(********************************* Events ******************************)
open Instruct
(* *)
(***********************************************************************)
-(* $Id: events.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Instruct
val get_pos : debug_event -> Lexing.position;;
(* *)
(***********************************************************************)
-(* $Id: exec.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Handling of keyboard interrupts *)
let interrupted = ref false
"Win32" -> ()
| _ ->
Sys.set_signal Sys.sigint (Sys.Signal_handle break);
- Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file))
+ Sys.set_signal Sys.sigpipe (Sys.Signal_handle(fun _ -> raise End_of_file))
let protect f =
if !is_protected then
(* *)
(***********************************************************************)
-(* $Id: exec.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Handling of keyboard interrupts *)
val protect : (unit -> unit) -> unit
(* *)
(***********************************************************************)
-(* $Id: frames.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(***************************** Frames **********************************)
open Instruct
(* *)
(***********************************************************************)
-(* $Id: frames.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(****************************** Frames *********************************)
open Instruct
(* *)
(***********************************************************************)
-(* $Id: history.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Int64ops
open Checkpoints
open Primitives
(* *)
(***********************************************************************)
-(* $Id: history.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
val empty_history : unit -> unit
val add_current_time : unit -> unit
(* *)
(***********************************************************************)
-(* $Id: input_handling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(**************************** Input control ****************************)
open Unix
(* *)
(***********************************************************************)
-(* $Id: input_handling.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(***************************** Input control ***************************)
open Primitives
(* *)
(***********************************************************************)
-(* $Id: int64ops.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(****************** arithmetic operators for Int64 *********************)
let ( ++ ) = Int64.add;;
(* *)
(***********************************************************************)
-(* $Id: int64ops.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(****************** arithmetic operators for Int64 *********************)
val ( ++ ) : int64 -> int64 -> int64;;
(* *)
(***********************************************************************)
-(* $Id: lexer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
val line: Lexing.lexbuf -> string
val lexeme: Lexing.lexbuf -> Parser.token
val argument: Lexing.lexbuf -> Parser.token
(* *)
(***********************************************************************)
-(* $Id: lexer.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
{
open Parser
(* *)
(***********************************************************************)
-(* $Id: loadprinter.ml 12673 2012-07-09 12:40:51Z xclerc $ *)
-
(* Loading and installation of user-defined printer functions *)
open Misc
(* *)
(***********************************************************************)
-(* $Id: loadprinter.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Loading and installation of user-defined printer functions *)
open Format
(* *)
(***********************************************************************)
-(* $Id: main.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Input_handling
open Question
open Command_line
protect ppf restart (function ppf ->
let b =
if !current_duration = -1L then begin
- let msg = sprintf "Restart from time %Ld and try to get closer of the problem" time in
+ let msg = sprintf "Restart from time %Ld and try to get \
+ closer of the problem" time in
stop_user_input ();
if yes_or_no msg then
(current_duration := init_duration; true)
(* *)
(***********************************************************************)
-(* $Id: parameters.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Miscellaneous parameters *)
open Primitives
(* *)
(***********************************************************************)
-(* $Id: parameters.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Miscellaneous parameters *)
val program_name : string ref
/* */
/***********************************************************************/
-/* $Id: parser.mly 12210 2012-03-08 19:52:03Z doligez $ */
-
%{
open Int64ops
(* *)
(***********************************************************************)
-(* $Id: parser_aux.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*open Globals*)
open Primitives
(* *)
(***********************************************************************)
-(* $Id: pattern_matching.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(************************ Simple pattern matching **********************)
open Debugger_config
| P_nth (n, patt) ->
if n >= List.length ty_list then
(prerr_endline "Out of range."; raise Toplevel);
- pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n)
+ pattern_matching patt (Debugcom.get_field obj n)
+ (List.nth ty_list n)
| _ ->
error_matching ())
| Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list ->
filter (ty_res, ty)
with Unify ->
fatal_error "pattern_matching: types should match");
- pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg
+ pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos)
+ ty_arg
in
(match pattern with
P_record pattern_label_list ->
(* *)
(***********************************************************************)
-(* $Id: pattern_matching.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(************************ Simple pattern matching **********************)
open Parser_aux
val pattern_matching :
- pattern -> Debugcom.remote_value -> Typedtree.type_expr -> (string * Debugcom.remote_value * Typedtree.type_expr) list;;
+ pattern -> Debugcom.remote_value -> Typedtree.type_expr ->
+ (string * Debugcom.remote_value * Typedtree.type_expr) list;;
(* *)
(***********************************************************************)
-(* $Id: pos.ml 11166 2011-08-04 14:59:13Z doligez $ *)
-
open Instruct;;
open Lexing;;
open Location;;
(* *)
(***********************************************************************)
-(* $Id: pos.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
val get_desc : Instruct.debug_event -> string;;
(* *)
(***********************************************************************)
-(* $Id: primitives.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*********************** Basic functions and types *********************)
(*** Miscellaneous ***)
(* *)
(***********************************************************************)
-(* $Id: primitives.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(********************* Basic functions and types ***********************)
(*** Miscellaneous ***)
(* *)
(***********************************************************************)
-(* $Id: printval.ml 12689 2012-07-10 14:54:19Z doligez $ *)
-
(* To print values *)
open Format
let n = name_value obj ty in
fprintf ppf "$%i" n in
Printtyp.reset_and_mark_loops ty;
- fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@."
+ fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@."
print_value_name exp
Printtyp.type_expr ty
(print_value max_depth env obj) ty
(* *)
(***********************************************************************)
-(* $Id: printval.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Format
val max_printer_depth : int ref
(* *)
(***********************************************************************)
-(* $Id: program_loading.ml 12352 2012-04-13 12:43:24Z doligez $ *)
-
(* Program loading *)
open Unix
(* *)
(***********************************************************************)
-(* $Id: program_loading.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*** Debugging. ***)
val debug_loading : bool ref
(* *)
(***********************************************************************)
-(* $Id: program_management.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Manage the loading of the program *)
open Int64ops
(* *)
(***********************************************************************)
-(* $Id: program_management.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*** Program loading and initializations. ***)
val loaded : bool ref
(* *)
(***********************************************************************)
-(* $Id: show_information.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Instruct
open Format
open Debugcom
(* Display information about the current event. *)
let show_current_event ppf =
- fprintf ppf "Time : %Li" (current_time ());
+ fprintf ppf "Time: %Li" (current_time ());
(match current_pc () with
| Some pc ->
- fprintf ppf " - pc : %i" pc
+ fprintf ppf " - pc: %i" pc
| _ -> ());
update_current_event ();
reset_frame ();
| [] ->
()
| [breakpoint] ->
- fprintf ppf "Breakpoint : %i@." breakpoint
+ fprintf ppf "Breakpoint: %i@." breakpoint
| breakpoints ->
- fprintf ppf "Breakpoints : %a@."
+ fprintf ppf "Breakpoints: %a@."
(fun ppf l ->
List.iter
(function x -> fprintf ppf "%i " x) l)
let buffer = get_buffer pos event.ev_module in
snd (start_and_cnum buffer pos)
with _ -> pos.Lexing.pos_cnum in
- fprintf ppf "#%i Pc : %i %s char %i@."
+ fprintf ppf "#%i Pc: %i %s char %i@."
framenum event.ev_pos event.ev_module
cnum
begin match breakpoints_at_pc sel_ev.ev_pos with
| [] -> ()
| [breakpoint] ->
- fprintf ppf "Breakpoint : %i@." breakpoint
+ fprintf ppf "Breakpoint: %i@." breakpoint
| breakpoints ->
- fprintf ppf "Breakpoints : %a@."
+ fprintf ppf "Breakpoints: %a@."
(fun ppf l ->
List.iter (function x -> fprintf ppf "%i " x) l)
(List.sort compare breakpoints);
(* *)
(***********************************************************************)
-(* $Id: show_information.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Format;;
(* Display information about the current event. *)
(* *)
(***********************************************************************)
-(* $Id: show_source.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Debugger_config
open Instruct
open Parameters
let buffer = get_buffer pos mdle in
let rec aff (line_start, line_number) =
if line_number <= stop then
- aff (print_line buffer line_number line_start point before + 1, line_number + 1)
+ aff (print_line buffer line_number line_start point before + 1,
+ line_number + 1)
in
aff (pos_of_line buffer start)
with
(* *)
(***********************************************************************)
-(* $Id: show_source.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Print the line containing the point *)
val show_point : Instruct.debug_event -> bool -> unit;;
val show_no_point : unit -> unit;;
(* Display part of the source. *)
-val show_listing : Lexing.position -> string -> int -> int -> int -> bool -> unit;;
+val show_listing :
+ Lexing.position -> string -> int -> int -> int -> bool -> unit
+;;
(* *)
(***********************************************************************)
-(* $Id: source.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(************************ Source management ****************************)
open Misc
let innermost_module =
try
let dot_index = String.rindex mdle '.' in
- String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index))
+ String.sub mdle (succ dot_index) (pred (String.length mdle - dot_index))
with Not_found -> mdle in
let rec loop =
function
(* *)
(***********************************************************************)
-(* $Id: source.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(************************ Source management ****************************)
(*** Conversion function. ***)
(* *)
(***********************************************************************)
-(* $Id: symbols.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Handling of symbol tables (globals and events) *)
open Instruct
begin try
ignore (Bytesections.seek_section ic "CODE")
with Not_found ->
- (* The file contains only debugging info, loading mode is forced to "manual" *)
+ (* The file contains only debugging info,
+ loading mode is forced to "manual" *)
set_launching_function (List.assoc "manual" loading_modes)
end;
close_in_noerr ic;
(* *)
(***********************************************************************)
-(* $Id: symbols.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Modules used by the program. *)
val modules : string list ref
(* *)
(***********************************************************************)
-(* $Id: time_travel.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(**************************** Time travel ******************************)
open Int64ops
(* Select a checkpoint as current. *)
let set_current_checkpoint checkpoint =
if !debug_time_travel then
- prerr_endline ("Select : " ^ (string_of_int checkpoint.c_pid));
+ prerr_endline ("Select: " ^ (string_of_int checkpoint.c_pid));
if not checkpoint.c_valid then
wait_for_connection checkpoint;
current_checkpoint := checkpoint;
(* Kill `checkpoint'. *)
let kill_checkpoint checkpoint =
if !debug_time_travel then
- prerr_endline ("Kill : " ^ (string_of_int checkpoint.c_pid));
+ prerr_endline ("Kill: " ^ (string_of_int checkpoint.c_pid));
if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *)
(if not checkpoint.c_valid then
wait_for_connection checkpoint;
Checkpoint_done pid ->
(new_checkpoint.c_pid <- pid;
if !debug_time_travel then
- prerr_endline ("Waiting for connection : " ^ (string_of_int pid)))
+ prerr_endline ("Waiting for connection: " ^ string_of_int pid))
| Checkpoint_failed ->
prerr_endline
"A fork failed. Reducing maximum number of checkpoints.";
set_current_checkpoint
(find_checkpoint_before (current_time ()))));
if !debug_time_travel then begin
- print_string "Checkpoints : pid(time)"; print_newline ();
+ print_string "Checkpoints: pid(time)"; print_newline ();
List.iter
(function {c_time = time; c_pid = pid; c_valid = valid} ->
Printf.printf "%d(%Ld)%s " pid time
true)
in
if !debug_time_travel then
- prerr_endline ("New connection : " ^(string_of_int pid));
+ prerr_endline ("New connection: " ^(string_of_int pid));
find (!current_checkpoint::!checkpoints)
(* Kill all the checkpoints. *)
(* *)
(***********************************************************************)
-(* $Id: time_travel.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(**************************** Time travel ******************************)
open Primitives
(* *)
(***********************************************************************)
-(* $Id: trap_barrier.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(************************** Trap barrier *******************************)
open Debugcom
(* *)
(***********************************************************************)
-(* $Id: trap_barrier.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(************************* Trap barrier ********************************)
val install_trap_barrier : int -> unit
(* *)
(***********************************************************************)
-(* $Id: unix_tools.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(****************** Tools for Unix *************************************)
open Misc
ADDR_INET
((try inet_addr_of_string host with Failure _ ->
try (gethostbyname host).h_addr_list.(0) with Not_found ->
- prerr_endline ("Unknown host : " ^ host);
+ prerr_endline ("Unknown host: " ^ host);
failwith "Can't convert address"),
(try int_of_string port with Failure _ ->
prerr_endline "The port number should be an integer";
(*** Report a unix error. ***)
let report_error = function
| Unix_error (err, fun_name, arg) ->
- prerr_string "Unix error : '";
+ prerr_string "Unix error: '";
prerr_string fun_name;
prerr_string "' failed";
if String.length arg > 0 then
(prerr_string " on '";
prerr_string arg;
prerr_string "'");
- prerr_string " : ";
+ prerr_string ": ";
prerr_endline (error_message err)
| _ -> fatal_error "report_error: not a Unix error"
(* *)
(***********************************************************************)
-(* $Id: unix_tools.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(**************************** Tools for Unix ***************************)
open Unix
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright 2013 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Clflags
+
+let output_prefix name =
+ let oname =
+ match !output_name with
+ | None -> name
+ | Some n -> if !compile_only then (output_name := None; n) else name in
+ Misc.chop_extension_if_any oname
+
+let print_version_and_library compiler =
+ Printf.printf "The OCaml %s, version " compiler;
+ print_string Config.version; print_newline();
+ print_string "Standard library directory: ";
+ print_string Config.standard_library; print_newline();
+ exit 0
+
+let print_version_string () =
+ print_string Config.version; print_newline(); exit 0
+
+let print_standard_library () =
+ print_string Config.standard_library; print_newline(); exit 0
+
+let fatal err =
+ prerr_endline err;
+ exit 2
+
+let extract_output = function
+ | Some s -> s
+ | None ->
+ fatal "Please specify the name of the output file, using option -o"
+
+let default_output = function
+ | Some s -> s
+ | None -> Config.default_executable_name
+
+let implicit_modules = ref []
+let first_include_dirs = ref []
+let last_include_dirs = ref []
+let first_ccopts = ref []
+let last_ccopts = ref []
+let first_ppx = ref []
+let last_ppx = ref []
+let first_objfiles = ref []
+let last_objfiles = ref []
+
+(* Note: this function is duplicated in optcompile.ml *)
+let check_unit_name ppf filename name =
+ try
+ begin match name.[0] with
+ | 'A'..'Z' -> ()
+ | _ ->
+ Location.print_warning (Location.in_file filename) ppf
+ (Warnings.Bad_module_name name);
+ raise Exit;
+ end;
+ for i = 1 to String.length name - 1 do
+ match name.[i] with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
+ | _ ->
+ Location.print_warning (Location.in_file filename) ppf
+ (Warnings.Bad_module_name name);
+ raise Exit;
+ done;
+ with Exit -> ()
+;;
+
+
+
+
+
+
+
+type readenv_position =
+ Before_args | Before_compile | Before_link
+
+(* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)*
+ where VALUE should not contain ',' *)
+exception SyntaxError of string
+
+let parse_args s =
+ let args = Misc.split s ',' in
+ let rec iter is_after args before after =
+ match args with
+ [] ->
+ if not is_after then
+ raise (SyntaxError "no '_' separator found")
+ else
+ (List.rev before, List.rev after)
+ | "_" :: _ when is_after -> raise (SyntaxError "too many '_' separators")
+ | "_" :: tail -> iter true tail before after
+ | arg :: tail ->
+ let binding = try
+ Misc.cut_at arg '='
+ with Not_found ->
+ raise (SyntaxError ("missing '=' in " ^ arg))
+ in
+ if is_after then
+ iter is_after tail before (binding :: after)
+ else
+ iter is_after tail (binding :: before) after
+ in
+ iter false args [] []
+
+let setter ppf f name options s =
+ try
+ let bool = match s with
+ | "0" -> false
+ | "1" -> true
+ | _ -> raise Not_found
+ in
+ List.iter (fun b -> b := f bool) options
+ with Not_found ->
+ Location.print_warning Location.none ppf
+ (Warnings.Bad_env_variable ("OCAMLPARAM",
+ Printf.sprintf "bad value for %s" name))
+
+let read_OCAMLPARAM ppf position =
+ try
+ let s = Sys.getenv "OCAMLPARAM" in
+ let (before, after) =
+ try
+ parse_args s
+ with SyntaxError s ->
+ Location.print_warning Location.none ppf
+ (Warnings.Bad_env_variable ("OCAMLPARAM", s));
+ [],[]
+ in
+
+ let set name options s = setter ppf (fun b -> b) name options s in
+ let clear name options s = setter ppf (fun b -> not b) name options s in
+ List.iter (fun (name, v) ->
+ match name with
+ | "g" -> set "g" [ Clflags.debug ] v
+ | "p" -> set "p" [ Clflags.gprofile ] v
+ | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
+ | "annot" -> set "annot" [ Clflags.annotations ] v
+ | "absname" -> set "absname" [ Location.absname ] v
+ | "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
+ | "noassert" -> set "noassert" [ noassert ] v
+ | "noautolink" -> set "noautolink" [ no_auto_link ] v
+ | "nostdlib" -> set "nostdlib" [ no_std_include ] v
+ | "linkall" -> set "linkall" [ link_everything ] v
+ | "nolabels" -> set "nolabels" [ classic ] v
+ | "principal" -> set "principal" [ principal ] v
+ | "rectypes" -> set "rectypes" [ recursive_types ] v
+ | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
+ | "thread" -> set "thread" [ use_threads ] v
+ | "unsafe" -> set "unsafe" [ fast ] v
+ | "verbose" -> set "verbose" [ verbose ] v
+ | "nopervasives" -> set "nopervasives" [ nopervasives ] v
+ | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
+
+ | "compact" -> clear "compact" [ optimize_for_speed ] v
+ | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
+ | "nodynlink" -> clear "nodynlink" [ dlcode ] v
+ | "short-paths" -> clear "short-paths" [ real_paths ] v
+
+ | "pp" -> preprocessor := Some v
+ | "runtime-variant" -> runtime_variant := v
+ | "cc" -> c_compiler := Some v
+
+ (* assembly sources *)
+ | "s" ->
+ set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v
+ | "S" -> set "S" [ Clflags.keep_asm_file ] v
+ | "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v
+
+ (* warn-errors *)
+ | "we" | "warn-error" -> Warnings.parse_options true v
+ (* warnings *)
+ | "w" -> Warnings.parse_options false v
+ (* warn-errors *)
+ | "wwe" -> Warnings.parse_options false v
+
+ (* inlining *)
+ | "inline" -> begin try
+ inline_threshold := 8 * int_of_string v
+ with _ ->
+ Location.print_warning Location.none ppf
+ (Warnings.Bad_env_variable ("OCAMLPARAM",
+ "non-integer parameter for \"inline\""))
+ end
+
+ | "intf-suffix" -> Config.interface_suffix := v
+
+ | "I" -> begin
+ match position with
+ | Before_args -> first_include_dirs := v :: !first_include_dirs
+ | Before_link | Before_compile ->
+ last_include_dirs := v :: !last_include_dirs
+ end
+
+ | "cclib" ->
+ begin
+ match position with
+ | Before_compile -> ()
+ | Before_link | Before_args ->
+ ccobjs := Misc.rev_split_words v @ !ccobjs
+ end
+
+ | "ccopts" ->
+ begin
+ match position with
+ | Before_link | Before_compile ->
+ last_ccopts := v :: !last_ccopts
+ | Before_args ->
+ first_ccopts := v :: !first_ccopts
+ end
+
+ | "ppx" ->
+ begin
+ match position with
+ | Before_link | Before_compile ->
+ last_ppx := v :: !last_ppx
+ | Before_args ->
+ first_ppx := v :: !first_ppx
+ end
+
+
+ | "cmo" | "cma" ->
+ if not !native_code then
+ begin
+ match position with
+ | Before_link | Before_compile ->
+ last_objfiles := v ::! last_objfiles
+ | Before_args ->
+ first_objfiles := v :: !first_objfiles
+ end
+
+ | "cmx" | "cmxa" ->
+ if !native_code then
+ begin
+ match position with
+ | Before_link | Before_compile ->
+ last_objfiles := v ::! last_objfiles
+ | Before_args ->
+ first_objfiles := v :: !first_objfiles
+ end
+
+ | _ ->
+ Printf.eprintf
+ "Warning: discarding value of variable %S in OCAMLPARAM\n%!"
+ name
+ ) (match position with
+ Before_args -> before
+ | Before_compile | Before_link -> after)
+ with Not_found -> ()
+
+let readenv ppf position =
+ last_include_dirs := [];
+ last_ccopts := [];
+ last_ppx := [];
+ last_objfiles := [];
+ read_OCAMLPARAM ppf position;
+ all_ccopts := !last_ccopts @ !first_ccopts;
+ all_ppx := !last_ppx @ !first_ppx
+
+let get_objfiles () =
+ List.rev (!last_objfiles @ !objfiles @ !first_objfiles)
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright 2013 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+val check_unit_name : Format.formatter -> string -> string -> unit
+
+val output_prefix : string -> string
+val extract_output : string option -> string
+val default_output : string option -> string
+
+val print_version_and_library : string -> 'a
+val print_version_string : unit -> 'a
+val print_standard_library : unit -> 'a
+val fatal : string -> 'a
+
+val first_ccopts : string list ref
+val first_ppx : string list ref
+val first_include_dirs : string list ref
+val last_include_dirs : string list ref
+val implicit_modules : string list ref
+
+(* return the list of objfiles, after OCAMLPARAM and List.rev *)
+val get_objfiles : unit -> string list
+
+type readenv_position =
+ Before_args | Before_compile | Before_link
+
+val readenv : Format.formatter -> readenv_position -> unit
(* *)
(***********************************************************************)
-(* $Id: compile.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* The batch compiler *)
open Misc
open Config
open Format
open Typedtree
-
-(* Initialize the search path.
- The current directory is always searched first,
- then the directories specified with the -I option (in command-line order),
- then the standard library directory (unless the -nostdlib option is given).
- *)
-
-let init_path () =
- let dirs =
- if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
- else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs
- else !Clflags.include_dirs in
- let exp_dirs =
- List.map (expand_directory Config.standard_library) dirs in
- load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
- Env.reset_cache ()
-
-(* Return the initial environment in which compilation proceeds. *)
-
-(* Note: do not do init_path() in initial_env, this breaks
- toplevel initialization (PR#1775) *)
-let initial_env () =
- Ident.reinit();
- try
- if !Clflags.nopervasives
- then Env.initial
- else Env.open_pers_signature "Pervasives" Env.initial
- with Not_found ->
- fatal_error "cannot open pervasives.cmi"
-
-(* Note: this function is duplicated in optcompile.ml *)
-let check_unit_name ppf filename name =
- try
- begin match name.[0] with
- | 'A'..'Z' -> ()
- | _ ->
- Location.print_warning (Location.in_file filename) ppf
- (Warnings.Bad_module_name name);
- raise Exit;
- end;
- for i = 1 to String.length name - 1 do
- match name.[i] with
- | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
- | _ ->
- Location.print_warning (Location.in_file filename) ppf
- (Warnings.Bad_module_name name);
- raise Exit;
- done;
- with Exit -> ()
-;;
+open Compenv
(* Compile a .mli file *)
let interface ppf sourcefile outputprefix =
Location.input_name := sourcefile;
- init_path ();
+ Compmisc.init_path false;
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
check_unit_name ppf sourcefile modulename;
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
- let initial_env = initial_env () in
+ let initial_env = Compmisc.initial_env () in
try
let ast =
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
let tsg = Typemod.transl_signature initial_env ast in
+ if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
+ let sg = tsg.sig_type in
if !Clflags.print_types then
- fprintf std_formatter "%a@." Printtyp.signature
- (Typemod.simplify_signature tsg.sig_type);
+ Printtyp.wrap_printing_env initial_env (fun () ->
+ fprintf std_formatter "%a@."
+ Printtyp.signature (Typemod.simplify_signature sg));
+ ignore (Includemod.signatures initial_env sg sg);
+ Typecore.force_delayed_checks ();
Warnings.check_fatal ();
if not !Clflags.print_types then begin
- let sg = Env.save_signature tsg.sig_type modulename (outputprefix ^ ".cmi") in
+ let sg = Env.save_signature sg modulename (outputprefix ^ ".cmi") in
Typemod.save_signature modulename tsg outputprefix sourcefile
- initial_env sg ;
+ initial_env sg ;
end;
Pparse.remove_preprocessed inputfile
with e ->
- Pparse.remove_preprocessed_if_ast inputfile;
+ Pparse.remove_preprocessed inputfile;
raise e
(* Compile a .ml file *)
let implementation ppf sourcefile outputprefix =
Location.input_name := sourcefile;
- init_path ();
+ Compmisc.init_path false;
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
check_unit_name ppf sourcefile modulename;
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
- let env = initial_env() in
+ let env = Compmisc.initial_env() in
if !Clflags.print_types then begin
try ignore(
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Typemod.type_implementation sourcefile outputprefix modulename env);
+ ++ print_if ppf Clflags.dump_source Pprintast.structure
+ ++ Typemod.type_implementation sourcefile outputprefix modulename env
+ ++ print_if ppf Clflags.dump_typedtree
+ Printtyped.implementation_with_coercion);
Warnings.check_fatal ();
Pparse.remove_preprocessed inputfile;
Stypes.dump (Some (outputprefix ^ ".annot"));
with x ->
- Pparse.remove_preprocessed_if_ast inputfile;
+ Pparse.remove_preprocessed inputfile;
Stypes.dump (Some (outputprefix ^ ".annot"));
raise x
end else begin
try
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ print_if ppf Clflags.dump_source Pprintast.structure
++ Typemod.type_implementation sourcefile outputprefix modulename env
+ ++ print_if ppf Clflags.dump_typedtree
+ Printtyped.implementation_with_coercion
++ Translmod.transl_implementation modulename
++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
++ Simplif.simplify_lambda
with x ->
close_out oc;
remove_file objfile;
- Pparse.remove_preprocessed_if_ast inputfile;
+ Pparse.remove_preprocessed inputfile;
Stypes.dump (Some (outputprefix ^ ".annot"));
raise x
end
(* *)
(***********************************************************************)
-(* $Id: compile.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Compile a .ml or .mli file *)
open Format
val interface: formatter -> string -> string -> unit
val implementation: formatter -> string -> string -> unit
val c_file: string -> unit
-
-val initial_env: unit -> Env.t
-val init_path: unit -> unit
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright 2013 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Compenv
+
+(* Initialize the search path.
+ The current directory is always searched first,
+ then the directories specified with the -I option (in command-line order),
+ then the standard library directory (unless the -nostdlib option is given).
+ *)
+
+let init_path native =
+ let dirs =
+ if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
+ else if !Clflags.use_vmthreads && not native then
+ "+vmthreads" :: !Clflags.include_dirs
+ else
+ !last_include_dirs @
+ !Clflags.include_dirs @
+ !first_include_dirs
+ in
+ let exp_dirs =
+ List.map (Misc.expand_directory Config.standard_library) dirs in
+ Config.load_path := "" ::
+ List.rev_append exp_dirs (Clflags.std_include_dir ());
+ Env.reset_cache ()
+
+(* Return the initial environment in which compilation proceeds. *)
+
+(* Note: do not do init_path() in initial_env, this breaks
+ toplevel initialization (PR#1775) *)
+
+let open_implicit_module m env =
+ try
+ Env.open_pers_signature m env
+ with Not_found ->
+ Misc.fatal_error (Printf.sprintf "cannot open implicit module %S" m)
+
+let initial_env () =
+ Ident.reinit();
+ let env =
+ if !Clflags.nopervasives
+ then Env.initial
+ else
+ open_implicit_module "Pervasives" Env.initial
+ in
+ List.fold_left (fun env m ->
+ open_implicit_module m env
+ ) env !implicit_modules
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright 2013 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+val init_path : bool -> unit
+val initial_env : unit -> Env.t
(* *)
(***********************************************************************)
-(* $Id: errors.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* WARNING: if you change something in this file, you must look at
opterrors.ml and ocamldoc/odoc_analyse.ml
to see if you need to make the same changes there.
Lexer.report_error ppf err
| Syntaxerr.Error err ->
Syntaxerr.report_error ppf err
- | Pparse.Error ->
- Location.print_error_cur_file ppf;
- fprintf ppf "Preprocessor error"
+ | Pparse.Error err ->
+ Pparse.report_error ppf err
| Env.Error err ->
Location.print_error_cur_file ppf;
Env.report_error ppf err
fprintf ppf
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value.@ Change one of them." l l'
- | Typecore.Error(loc, err) ->
- Location.print_error ppf loc; Typecore.report_error ppf err
- | Typetexp.Error(loc, err) ->
- Location.print_error ppf loc; Typetexp.report_error ppf err
+ | Typecore.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typecore.report_error env ppf err
+ | Typetexp.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typetexp.report_error env ppf err
| Typedecl.Error(loc, err) ->
Location.print_error ppf loc; Typedecl.report_error ppf err
- | Typeclass.Error(loc, err) ->
- Location.print_error ppf loc; Typeclass.report_error ppf err
+ | Typeclass.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typeclass.report_error env ppf err
| Includemod.Error err ->
Location.print_error_cur_file ppf;
Includemod.report_error ppf err
- | Typemod.Error(loc, err) ->
- Location.print_error ppf loc; Typemod.report_error ppf err
+ | Typemod.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typemod.report_error env ppf err
| Translcore.Error(loc, err) ->
Location.print_error ppf loc; Translcore.report_error ppf err
| Translclass.Error(loc, err) ->
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
Location.print_error_cur_file ppf;
- fprintf ppf "Error-enabled warnings (%d occurrences)" n
+ fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn
(* *)
(***********************************************************************)
-(* $Id: errors.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Error report *)
open Format
(* *)
(***********************************************************************)
-(* $Id: main.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Config
open Clflags
-
-let output_prefix name =
- let oname =
- match !output_name with
- | None -> name
- | Some n -> if !compile_only then (output_name := None; n) else name in
- Misc.chop_extension_if_any oname
+open Compenv
let process_interface_file ppf name =
Compile.interface ppf name (output_prefix name)
else
raise(Arg.Bad("don't know what to do with " ^ name))
-let print_version_and_library () =
- print_string "The OCaml compiler, version ";
- print_string Config.version; print_newline();
- print_string "Standard library directory: ";
- print_string Config.standard_library; print_newline();
- exit 0
-
-let print_version_string () =
- print_string Config.version; print_newline(); exit 0
-
-let print_standard_library () =
- print_string Config.standard_library; print_newline(); exit 0
-
let usage = "Usage: ocamlc <options> <files>\nOptions are:"
let ppf = Format.err_formatter
(* Error messages to standard error formatter *)
-let anonymous = process_file ppf;;
-let impl = process_implementation_file ppf;;
-let intf = process_interface_file ppf;;
+let anonymous filename =
+ readenv ppf Before_compile; process_file ppf filename;;
+let impl filename =
+ readenv ppf Before_compile; process_implementation_file ppf filename;;
+let intf filename =
+ readenv ppf Before_compile; process_interface_file ppf filename;;
let show_config () =
Config.print_config stdout;
let _c = set compile_only
let _cc s = c_compiler := Some s
let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
- let _ccopt s = ccopts := s :: !ccopts
+ let _ccopt s = first_ccopts := s :: !first_ccopts
+ let _compat_32 = set bytecode_compatible_32
let _config = show_config
let _custom = set custom_runtime
let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
let _output_obj () = output_c_object := true; custom_runtime := true
let _pack = set make_package
let _pp s = preprocessor := Some s
+ let _ppx s = first_ppx := s :: !first_ppx
let _principal = set principal
let _rectypes = set recursive_types
let _runtime_variant s = runtime_variant := s
+ let _short_paths = unset real_paths
let _strict_sequence = set strict_sequence
let _thread = set use_threads
let _vmthread = set use_vmthreads
let _unsafe = set fast
let _use_prims s = use_prims := s
let _use_runtime s = use_runtime := s
- let _v = print_version_and_library
+ let _v () = print_version_and_library "compiler"
let _version = print_version_string
let _vnum = print_version_string
let _w = (Warnings.parse_options false)
let _where = print_standard_library
let _verbose = set verbose
let _nopervasives = set nopervasives
+ let _dsource = set dump_source
let _dparsetree = set dump_parsetree
+ let _dtypedtree = set dump_typedtree
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _dinstr = set dump_instr
let anonymous = anonymous
end)
-let fatal err =
- prerr_endline err;
- exit 2
-
-let extract_output = function
- | Some s -> s
- | None -> fatal "Please specify the name of the output file, using option -o"
-
-let default_output = function
- | Some s -> s
- | None -> Config.default_executable_name
-
let main () =
try
+ readenv ppf Before_args;
Arg.parse Options.list anonymous usage;
+ readenv ppf Before_link;
if
List.length (List.filter (fun x -> !x)
[make_archive;make_package;compile_only;output_c_object])
else
fatal "Please specify at most one of -pack, -a, -c, -output-obj";
if !make_archive then begin
- Compile.init_path();
+ Compmisc.init_path false;
- Bytelibrarian.create_archive ppf (List.rev !objfiles)
+ Bytelibrarian.create_archive ppf (Compenv.get_objfiles ())
(extract_output !output_name);
Warnings.check_fatal ();
end
else if !make_package then begin
- Compile.init_path();
+ Compmisc.init_path false;
let extracted_output = extract_output !output_name in
- let revd = List.rev !objfiles in
+ let revd = get_objfiles () in
Bytepackager.package_files ppf revd (extracted_output);
Warnings.check_fatal ();
end
else
default_output !output_name
in
- Compile.init_path();
- Bytelink.link ppf (List.rev !objfiles) target;
+ Compmisc.init_path false;
+ Bytelink.link ppf (get_objfiles ()) target;
Warnings.check_fatal ();
end;
exit 0
(* *)
(***********************************************************************)
-(* $Id: main.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*
this "empty" file is here to speed up garbage collection in ocamlc.opt
*)
(* *)
(***********************************************************************)
-(* $Id: main_args.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
let mk_a f =
"-a", Arg.Unit f, " Build a library"
;;
let mk_absname f =
- "-absname", Arg.Unit f, " Show absolute filenames in error message"
+ "-absname", Arg.Unit f, " Show absolute filenames in error messages"
;;
let mk_annot f =
;;
let mk_ccopt f =
- "-ccopt", Arg.String f, "<opt> Pass option <opt> to the C compiler and linker"
+ "-ccopt", Arg.String f,
+ "<opt> Pass option <opt> to the C compiler and linker"
;;
let mk_compact f =
"-compact", Arg.Unit f, " Optimize code size rather than speed"
;;
+let mk_compat_32 f =
+ "-compat-32", Arg.Unit f,
+ " Check that generated bytecode can run on 32-bit platforms"
+;;
+
let mk_config f =
"-config", Arg.Unit f, " Print configuration values and exit"
;;
"-pp", Arg.String f, "<command> Pipe sources through preprocessor <command>"
;;
+let mk_ppx f =
+ "-ppx", Arg.String f,
+ "<command> Pipe abstract syntax trees through preprocessor <command>"
+;;
+
let mk_principal f =
"-principal", Arg.Unit f, " Check principality of type inference"
;;
"-S", Arg.Unit f, " Keep intermediate assembly file"
;;
+let mk_short_paths f =
+ "-short-paths", Arg.Unit f, " Shorten paths in types"
+;;
+
let mk_stdin f =
"-stdin", Arg.Unit f, " Read script from standard input"
;;
" Print compiler version and location of standard library and exit"
;;
-let mk_version f =
- "-version", Arg.Unit f, " Print version and exit"
-;;
-
-let mk_vnum f =
- "-vnum", Arg.Unit f, " Print version number and exit"
-;;
-
let mk_verbose f =
"-verbose", Arg.Unit f, " Print calls to external commands"
;;
+let mk_version f =
+ "-version", Arg.Unit f, " Print version and exit"
+;;
+
let mk_vmthread f =
"-vmthread", Arg.Unit f,
" Generate code that supports the threads library with VM-level\n\
\ scheduling"
;;
+let mk_vnum f =
+ "-vnum", Arg.Unit f, " Print version number and exit"
+;;
+
let mk_w f =
"-w", Arg.String f,
Printf.sprintf
;;
let mk_warn_help f =
- "-warn-help", Arg.Unit f, " Show description of warning numbers"
+ "-warn-help", Arg.Unit f, " Show description of warning numbers"
;;
let mk_where f =
"-dparsetree", Arg.Unit f, " (undocumented)"
;;
+let mk_dtypedtree f =
+ "-dtypedtree", Arg.Unit f, " (undocumented)"
+;;
+
let mk_drawlambda f =
"-drawlambda", Arg.Unit f, " (undocumented)"
;;
+let mk_dsource f =
+ "-dsource", Arg.Unit f, " (undocumented)"
+;;
+
let mk_dlambda f =
"-dlambda", Arg.Unit f, " (undocumented)"
;;
val _cc : string -> unit
val _cclib : string -> unit
val _ccopt : string -> unit
+ val _compat_32 : unit -> unit
val _config : unit -> unit
val _custom : unit -> unit
val _dllib : string -> unit
val _output_obj : unit -> unit
val _pack : unit -> unit
val _pp : string -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
val _runtime_variant : string -> unit
+ val _short_paths : unit -> unit
val _strict_sequence : unit -> unit
val _thread : unit -> unit
val _vmthread : unit -> unit
val _nopervasives : unit -> unit
val _use_prims : string -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dinstr : unit -> unit
val _noprompt : unit -> unit
val _nopromptcont : unit -> unit
val _nostdlib : unit -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
+ val _short_paths : unit -> unit
val _stdin: unit -> unit
val _strict_sequence : unit -> unit
val _unsafe : unit -> unit
val _warn_error : string -> unit
val _warn_help : unit -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dinstr : unit -> unit
val _p : unit -> unit
val _pack : unit -> unit
val _pp : string -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
val _runtime_variant : string -> unit
val _S : unit -> unit
- val _strict_sequence : unit -> unit
val _shared : unit -> unit
+ val _short_paths : unit -> unit
+ val _strict_sequence : unit -> unit
val _thread : unit -> unit
val _unsafe : unit -> unit
val _v : unit -> unit
+ val _verbose : unit -> unit
val _version : unit -> unit
val _vnum : unit -> unit
- val _verbose : unit -> unit
val _w : string -> unit
val _warn_error : string -> unit
val _warn_help : unit -> unit
val _where : unit -> unit
val _nopervasives : unit -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
val _noprompt : unit -> unit
val _nopromptcont : unit -> unit
val _nostdlib : unit -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
val _S : unit -> unit
+ val _short_paths : unit -> unit
val _stdin : unit -> unit
val _strict_sequence : unit -> unit
val _unsafe : unit -> unit
val _warn_error : string -> unit
val _warn_help : unit -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
mk_cc F._cc;
mk_cclib F._cclib;
mk_ccopt F._ccopt;
+ mk_compat_32 F._compat_32;
mk_config F._config;
mk_custom F._custom;
mk_dllib F._dllib;
mk_output_obj F._output_obj;
mk_pack_byt F._pack;
mk_pp F._pp;
+ mk_ppx F._ppx;
mk_principal F._principal;
mk_rectypes F._rectypes;
mk_runtime_variant F._runtime_variant;
+ mk_short_paths F._short_paths;
mk_strict_sequence F._strict_sequence;
mk_thread F._thread;
mk_unsafe F._unsafe;
mk_use_runtime F._use_runtime;
mk_use_runtime_2 F._use_runtime;
mk_v F._v;
- mk_version F._version;
- mk_vnum F._vnum;
mk_verbose F._verbose;
+ mk_version F._version;
mk_vmthread F._vmthread;
+ mk_vnum F._vnum;
mk_w F._w;
mk_warn_error F._warn_error;
mk_warn_help F._warn_help;
mk_nopervasives F._nopervasives;
mk_use_prims F._use_prims;
+ mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
+ mk_dtypedtree F._dtypedtree;
mk_drawlambda F._drawlambda;
mk_dlambda F._dlambda;
mk_dinstr F._dinstr;
mk_noprompt F._noprompt;
mk_nopromptcont F._nopromptcont;
mk_nostdlib F._nostdlib;
+ mk_ppx F._ppx;
mk_principal F._principal;
mk_rectypes F._rectypes;
+ mk_short_paths F._short_paths;
mk_stdin F._stdin;
mk_strict_sequence F._strict_sequence;
mk_unsafe F._unsafe;
mk_warn_error F._warn_error;
mk_warn_help F._warn_help;
+ mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
+ mk_dtypedtree F._dtypedtree;
mk_drawlambda F._drawlambda;
mk_dlambda F._dlambda;
mk_dinstr F._dinstr;
mk_p F._p;
mk_pack_opt F._pack;
mk_pp F._pp;
+ mk_ppx F._ppx;
mk_principal F._principal;
mk_rectypes F._rectypes;
mk_runtime_variant F._runtime_variant;
mk_S F._S;
- mk_strict_sequence F._strict_sequence;
mk_shared F._shared;
+ mk_short_paths F._short_paths;
+ mk_strict_sequence F._strict_sequence;
mk_thread F._thread;
mk_unsafe F._unsafe;
mk_v F._v;
+ mk_verbose F._verbose;
mk_version F._version;
mk_vnum F._vnum;
- mk_verbose F._verbose;
mk_w F._w;
mk_warn_error F._warn_error;
mk_warn_help F._warn_help;
mk_where F._where;
mk_nopervasives F._nopervasives;
+ mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
+ mk_dtypedtree F._dtypedtree;
mk_drawlambda F._drawlambda;
mk_dlambda F._dlambda;
mk_dclambda F._dclambda;
mk_noprompt F._noprompt;
mk_nopromptcont F._nopromptcont;
mk_nostdlib F._nostdlib;
+ mk_ppx F._ppx;
mk_principal F._principal;
mk_rectypes F._rectypes;
mk_S F._S;
+ mk_short_paths F._short_paths;
mk_stdin F._stdin;
mk_strict_sequence F._strict_sequence;
mk_unsafe F._unsafe;
mk_warn_error F._warn_error;
mk_warn_help F._warn_help;
+ mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
+ mk_dtypedtree F._dtypedtree;
mk_drawlambda F._drawlambda;
mk_dclambda F._dclambda;
mk_dcmm F._dcmm;
(* *)
(***********************************************************************)
-(* $Id: main_args.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
module type Bytecomp_options =
sig
val _a : unit -> unit
val _cc : string -> unit
val _cclib : string -> unit
val _ccopt : string -> unit
+ val _compat_32 : unit -> unit
val _config : unit -> unit
val _custom : unit -> unit
val _dllib : string -> unit
val _output_obj : unit -> unit
val _pack : unit -> unit
val _pp : string -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
val _runtime_variant : string -> unit
+ val _short_paths : unit -> unit
val _strict_sequence : unit -> unit
val _thread : unit -> unit
val _vmthread : unit -> unit
val _nopervasives : unit -> unit
val _use_prims : string -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dinstr : unit -> unit
val _noprompt : unit -> unit
val _nopromptcont : unit -> unit
val _nostdlib : unit -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
+ val _short_paths : unit -> unit
val _stdin : unit -> unit
val _strict_sequence : unit -> unit
val _unsafe : unit -> unit
val _warn_error : string -> unit
val _warn_help : unit -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dinstr : unit -> unit
val _p : unit -> unit
val _pack : unit -> unit
val _pp : string -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
val _runtime_variant : string -> unit
val _S : unit -> unit
- val _strict_sequence : unit -> unit
val _shared : unit -> unit
+ val _short_paths : unit -> unit
+ val _strict_sequence : unit -> unit
val _thread : unit -> unit
val _unsafe : unit -> unit
val _v : unit -> unit
+ val _verbose : unit -> unit
val _version : unit -> unit
val _vnum : unit -> unit
- val _verbose : unit -> unit
val _w : string -> unit
val _warn_error : string -> unit
val _warn_help : unit -> unit
val _where : unit -> unit
val _nopervasives : unit -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
val _noprompt : unit -> unit
val _nopromptcont : unit -> unit
val _nostdlib : unit -> unit
+ val _ppx : string -> unit
val _principal : unit -> unit
val _rectypes : unit -> unit
val _S : unit -> unit
+ val _short_paths : unit -> unit
val _stdin : unit -> unit
val _strict_sequence : unit -> unit
val _unsafe : unit -> unit
val _warn_error : string -> unit
val _warn_help : unit -> unit
+ val _dsource : unit -> unit
val _dparsetree : unit -> unit
+ val _dtypedtree : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dclambda : unit -> unit
(* *)
(***********************************************************************)
-(* $Id: optcompile.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* The batch compiler *)
open Misc
open Config
open Format
open Typedtree
-
-(* Initialize the search path.
- The current directory is always searched first,
- then the directories specified with the -I option (in command-line order),
- then the standard library directory. *)
-
-let init_path () =
- let dirs =
- if !Clflags.use_threads
- then "+threads" :: !Clflags.include_dirs
- else !Clflags.include_dirs in
- let exp_dirs =
- List.map (expand_directory Config.standard_library) dirs in
- load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
- Env.reset_cache ()
-
-(* Return the initial environment in which compilation proceeds. *)
-
-let initial_env () =
- Ident.reinit();
- try
- if !Clflags.nopervasives
- then Env.initial
- else Env.open_pers_signature "Pervasives" Env.initial
- with Not_found ->
- fatal_error "cannot open pervasives.cmi"
-
-(* Note: this function is duplicated in compile.ml *)
-let check_unit_name ppf filename name =
- try
- begin match name.[0] with
- | 'A'..'Z' -> ()
- | _ ->
- Location.print_warning (Location.in_file filename) ppf
- (Warnings.Bad_module_name name);
- raise Exit;
- end;
- for i = 1 to String.length name - 1 do
- match name.[i] with
- | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
- | _ ->
- Location.print_warning (Location.in_file filename) ppf
- (Warnings.Bad_module_name name);
- raise Exit;
- done;
- with Exit -> ()
-;;
+open Compenv
(* Compile a .mli file *)
let interface ppf sourcefile outputprefix =
Location.input_name := sourcefile;
- init_path ();
+ Compmisc.init_path true;
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
check_unit_name ppf sourcefile modulename;
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
- let initial_env = initial_env() in
+ let initial_env = Compmisc.initial_env() in
try
let ast =
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
let tsg = Typemod.transl_signature initial_env ast in
+ if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
+ let sg = tsg.sig_type in
if !Clflags.print_types then
fprintf std_formatter "%a@." Printtyp.signature
- (Typemod.simplify_signature tsg.sig_type);
+ (Typemod.simplify_signature sg);
+ ignore (Includemod.signatures initial_env sg sg);
+ Typecore.force_delayed_checks ();
Warnings.check_fatal ();
if not !Clflags.print_types then begin
- let sg = Env.save_signature tsg.sig_type modulename (outputprefix ^ ".cmi") in
- Typemod.save_signature modulename tsg outputprefix sourcefile initial_env sg ;
+ let sg = Env.save_signature sg modulename (outputprefix ^ ".cmi") in
+ Typemod.save_signature modulename tsg outputprefix sourcefile
+ initial_env sg ;
end;
Pparse.remove_preprocessed inputfile;
Stypes.dump (Some (outputprefix ^ ".annot"))
with e ->
- Pparse.remove_preprocessed_if_ast inputfile;
+ Pparse.remove_preprocessed inputfile;
Stypes.dump (Some (outputprefix ^ ".annot"));
raise e
let implementation ppf sourcefile outputprefix =
Location.input_name := sourcefile;
- init_path ();
+ Compmisc.init_path true;
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
check_unit_name ppf sourcefile modulename;
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
- let env = initial_env() in
+ let env = Compmisc.initial_env() in
Compilenv.reset ?packname:!Clflags.for_package modulename;
let cmxfile = outputprefix ^ ".cmx" in
let objfile = outputprefix ^ ext_obj in
try
- if !Clflags.print_types then ignore(
+ if !Clflags.print_types then ignore begin
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Typemod.type_implementation sourcefile outputprefix modulename env)
- else begin
+ ++ print_if ppf Clflags.dump_source Pprintast.structure
+ ++ Typemod.type_implementation sourcefile outputprefix modulename env
+ ++ print_if ppf Clflags.dump_typedtree
+ Printtyped.implementation_with_coercion
+ end else begin
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ print_if ppf Clflags.dump_source Pprintast.structure
++ Typemod.type_implementation sourcefile outputprefix modulename env
+ ++ print_if ppf Clflags.dump_typedtree
+ Printtyped.implementation_with_coercion
++ Translmod.transl_store_implementation modulename
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+++ Simplif.simplify_lambda
with x ->
remove_file objfile;
remove_file cmxfile;
- Pparse.remove_preprocessed_if_ast inputfile;
+ Pparse.remove_preprocessed inputfile;
Stypes.dump (Some (outputprefix ^ ".annot"));
raise x
(* *)
(***********************************************************************)
-(* $Id: optcompile.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Compile a .ml or .mli file *)
open Format
val interface: formatter -> string -> string -> unit
val implementation: formatter -> string -> string -> unit
val c_file: string -> unit
-
-val initial_env: unit -> Env.t
-val init_path: unit -> unit
(* *)
(***********************************************************************)
-(* $Id: opterrors.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* WARNING: if you change something in this file, you must look at
errors.ml to see if you need to make the same changes there.
*)
Lexer.report_error ppf err
| Syntaxerr.Error err ->
Syntaxerr.report_error ppf err
- | Pparse.Error ->
- Location.print_error_cur_file ppf;
- fprintf ppf "Preprocessor error"
+ | Pparse.Error err ->
+ Pparse.report_error ppf err
| Env.Error err ->
Location.print_error_cur_file ppf;
Env.report_error ppf err
fprintf ppf
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value.@ Change one of them." l l'
- | Typecore.Error(loc, err) ->
- Location.print_error ppf loc; Typecore.report_error ppf err
- | Typetexp.Error(loc, err) ->
- Location.print_error ppf loc; Typetexp.report_error ppf err
+ | Typecore.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typecore.report_error env ppf err
+ | Typetexp.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typetexp.report_error env ppf err
| Typedecl.Error(loc, err) ->
Location.print_error ppf loc; Typedecl.report_error ppf err
- | Typeclass.Error(loc, err) ->
- Location.print_error ppf loc; Typeclass.report_error ppf err
+ | Typeclass.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typeclass.report_error env ppf err
| Includemod.Error err ->
Location.print_error_cur_file ppf;
Includemod.report_error ppf err
- | Typemod.Error(loc, err) ->
- Location.print_error ppf loc; Typemod.report_error ppf err
+ | Typemod.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typemod.report_error env ppf err
| Translcore.Error(loc, err) ->
Location.print_error ppf loc; Translcore.report_error ppf err
| Translclass.Error(loc, err) ->
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
Location.print_error_cur_file ppf;
- fprintf ppf "Error-enabled warnings (%d occurrences)" n
+ fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn
(* *)
(***********************************************************************)
-(* $Id: opterrors.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Error report *)
val report_error: Format.formatter -> exn -> unit
(* *)
(***********************************************************************)
-(* $Id: optmain.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Config
open Clflags
-
-let output_prefix name =
- let oname =
- match !output_name with
- | None -> name
- | Some n -> if !compile_only then (output_name := None; n) else name in
- Misc.chop_extension_if_any oname
+open Compenv
let process_interface_file ppf name =
Optcompile.interface ppf name (output_prefix name)
else
raise(Arg.Bad("don't know what to do with " ^ name))
-let print_version_and_library () =
- print_string "The OCaml native-code compiler, version ";
- print_string Config.version; print_newline();
- print_string "Standard library directory: ";
- print_string Config.standard_library; print_newline();
- exit 0
-
-let print_version_string () =
- print_string Config.version; print_newline(); exit 0
-
-let print_standard_library () =
- print_string Config.standard_library; print_newline(); exit 0
-
-let fatal err =
- prerr_endline err;
- exit 2
-
-let extract_output = function
- | Some s -> s
- | None ->
- fatal "Please specify the name of the output file, using option -o"
-
-let default_output = function
- | Some s -> s
- | None -> Config.default_executable_name
-
let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
+let ppf = Format.err_formatter
+
(* Error messages to standard error formatter *)
-let anonymous = process_file Format.err_formatter;;
-let impl = process_implementation_file Format.err_formatter;;
-let intf = process_interface_file Format.err_formatter;;
+let anonymous filename =
+ readenv ppf Before_compile; process_file ppf filename;;
+let impl filename =
+ readenv ppf Before_compile; process_implementation_file ppf filename;;
+let intf filename =
+ readenv ppf Before_compile; process_interface_file ppf filename;;
let show_config () =
Config.print_config stdout;
let _c = set compile_only
let _cc s = c_compiler := Some s
let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
- let _ccopt s = ccopts := s :: !ccopts
+ let _ccopt s = first_ccopts := s :: !first_ccopts
let _compact = clear optimize_for_speed
let _config () = show_config ()
let _for_pack s = for_package := Some s
let _p = set gprofile
let _pack = set make_package
let _pp s = preprocessor := Some s
+ let _ppx s = first_ppx := s :: !first_ppx
let _principal = set principal
let _rectypes = set recursive_types
let _runtime_variant s = runtime_variant := s
+ let _short_paths = clear real_paths
let _strict_sequence = set strict_sequence
let _shared () = shared := true; dlcode := true
let _S = set keep_asm_file
let _thread = set use_threads
let _unsafe = set fast
- let _v () = print_version_and_library ()
+ let _v () = print_version_and_library "native-code compiler"
let _version () = print_version_string ()
let _vnum () = print_version_string ()
let _verbose = set verbose
let _where () = print_standard_library ()
let _nopervasives = set nopervasives
+ let _dsource = set dump_source
let _dparsetree = set dump_parsetree
+ let _dtypedtree = set dump_typedtree
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _dclambda = set dump_clambda
native_code := true;
let ppf = Format.err_formatter in
try
+ readenv ppf Before_args;
Arg.parse (Arch.command_line_options @ Options.list) anonymous usage;
+ readenv ppf Before_link;
if
List.length (List.filter (fun x -> !x)
[make_package; make_archive; shared;
if !make_archive then begin
if !cmxa_present then
fatal "Option -a cannot be used with .cmxa input files.";
- Optcompile.init_path();
+ Compmisc.init_path true;
let target = extract_output !output_name in
- Asmlibrarian.create_archive (List.rev !objfiles) target;
+ Asmlibrarian.create_archive (get_objfiles ()) target;
Warnings.check_fatal ();
end
else if !make_package then begin
- Optcompile.init_path();
+ Compmisc.init_path true;
let target = extract_output !output_name in
- Asmpackager.package_files ppf (List.rev !objfiles) target;
+ Asmpackager.package_files ppf (get_objfiles ()) target;
Warnings.check_fatal ();
end
else if !shared then begin
- Optcompile.init_path();
+ Compmisc.init_path true;
let target = extract_output !output_name in
- Asmlink.link_shared ppf (List.rev !objfiles) target;
+ Asmlink.link_shared ppf (get_objfiles ()) target;
Warnings.check_fatal ();
end
else if not !compile_only && !objfiles <> [] then begin
else
default_output !output_name
in
- Optcompile.init_path();
- Asmlink.link ppf (List.rev !objfiles) target;
+ Compmisc.init_path true;
+ Asmlink.link ppf (get_objfiles ()) target;
Warnings.check_fatal ();
end;
exit 0
(* *)
(***********************************************************************)
-(* $Id: optmain.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(*
this "empty" file is here to speed up garbage collection in ocamlopt.opt
*)
(* *)
(***********************************************************************)
-(* $Id: pparse.ml 12387 2012-04-20 15:33:56Z doligez $ *)
-
open Format
-exception Error
+type error =
+ | CannotRun of string
+ | WrongMagic of string
+
+exception Error of error
(* Optionally preprocess a source file *)
in
if Ccomp.command comm <> 0 then begin
Misc.remove_file tmpfile;
- raise Error;
+ raise (Error (CannotRun comm));
end;
tmpfile
None -> ()
| Some _ -> Misc.remove_file inputfile
-let remove_preprocessed_if_ast inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ ->
- if inputfile <> !Location.input_name then Misc.remove_file inputfile
+let write_ast magic ast =
+ let fn = Filename.temp_file "camlppx" "" in
+ let oc = open_out_bin fn in
+ output_string oc magic;
+ output_value oc !Location.input_name;
+ output_value oc ast;
+ close_out oc;
+ fn
+
+let apply_rewriter magic fn_in ppx =
+ let fn_out = Filename.temp_file "camlppx" "" in
+ let comm =
+ Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
+ in
+ let ok = Ccomp.command comm = 0 in
+ Misc.remove_file fn_in;
+ if not ok then begin
+ Misc.remove_file fn_out;
+ raise (Error (CannotRun comm));
+ end;
+ if not (Sys.file_exists fn_out) then raise (Error (WrongMagic comm));
+ (* check magic before passing to the next ppx *)
+ let ic = open_in_bin fn_out in
+ let buffer =
+ try Misc.input_bytes ic (String.length magic) with End_of_file -> "" in
+ close_in ic;
+ if buffer <> magic then begin
+ Misc.remove_file fn_out;
+ raise (Error (WrongMagic comm));
+ end;
+ fn_out
+
+let read_ast magic fn =
+ let ic = open_in_bin fn in
+ try
+ let buffer = Misc.input_bytes ic (String.length magic) in
+ assert(buffer = magic); (* already checked by apply_rewriter *)
+ Location.input_name := input_value ic;
+ let ast = input_value ic in
+ close_in ic;
+ Misc.remove_file fn;
+ ast
+ with exn ->
+ close_in ic;
+ Misc.remove_file fn;
+ raise exn
-(* Parse a file or get a dumped syntax tree in it *)
+let apply_rewriters magic ast =
+ match !Clflags.all_ppx with
+ | [] -> ast
+ | ppxs ->
+ let fn =
+ List.fold_left (apply_rewriter magic) (write_ast magic ast) ppxs in
+ read_ast magic fn
+
+(* Parse a file or get a dumped syntax tree from it *)
exception Outdated_version
try
if is_ast_file then begin
if !Clflags.fast then
+ (* FIXME make this a proper warning *)
fprintf ppf "@[Warning: %s@]@."
"option -unsafe used with a preprocessor returning a syntax tree";
Location.input_name := input_value ic;
with x -> close_in ic; raise x
in
close_in ic;
- ast
+ apply_rewriters ast_magic ast
+
+let report_error ppf = function
+ | CannotRun cmd ->
+ fprintf ppf "Error while running external preprocessor@.\
+ Command line: %s@." cmd
+ | WrongMagic cmd ->
+ fprintf ppf "External preprocessor does not produce a valid file@.\
+ Command line: %s@." cmd
(* *)
(***********************************************************************)
-(* $Id: pparse.mli 12058 2012-01-20 14:23:34Z frisch $ *)
-
open Format
-exception Error
+type error =
+ | CannotRun of string
+ | WrongMagic of string
+
+exception Error of error
val preprocess : string -> string
val remove_preprocessed : string -> unit
-val remove_preprocessed_if_ast : string -> unit
val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a
+val apply_rewriters : string -> 'a -> 'a
+val report_error : formatter -> error -> unit
# #
#########################################################################
-# $Id: Makefile 12118 2012-02-03 16:04:49Z doligez $
-
include ../config/Makefile
# Files to install
(byte-compile-file "inf-caml.el") \
(byte-compile-file "caml-help.el") \
(byte-compile-file "caml-types.el") \
+ (byte-compile-file "caml-font.el") \
(byte-compile-file "camldebug.el"))
install:
$(EMACS) --batch --eval '$(COMPILECMD)'
clean:
- rm -f ocamltags *~ #*# *.elc
+ rm -f ocamltags *~ \#*# *.elc
- OCaml emacs mode, snapshot of $Date: 2012-02-10 17:15:24 +0100 (Fri, 10 Feb 2012) $
+ OCaml emacs mode, snapshot of $Date$
The files in this archive define a caml-mode for emacs, for editing
OCaml and Objective Label programs, as well as an
;(* *)
;(***********************************************************************)
-;(* $Id: caml-compat.el 11156 2011-07-27 14:17:02Z doligez $ *)
-
;; function definitions for old versions of emacs
;; indent-line-to
;(* *)
;(***********************************************************************)
-;(* $Id: caml-emacs.el 11156 2011-07-27 14:17:02Z doligez $ *)
-
;; for caml-help.el
(defalias 'caml-info-other-window 'info-other-window)
(defalias 'caml-mouse-movement-p 'mouse-movement-p)
(defalias 'caml-sit-for 'sit-for)
-(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body))
+(defalias 'caml-track-mouse 'track-mouse)
(defun caml-event-window (e) (posn-window (event-start e)))
(defun caml-event-point-start (e) (posn-point (event-start e)))
(or (member 'drag modifiers)
(member 'click modifiers)))))
-(if (fboundp 'string-to-number)
- (defalias 'caml-string-to-int 'string-to-number)
- (defalias 'caml-string-to-int 'string-to-int))
+(defalias 'caml-string-to-int (if (fboundp 'string-to-number)
+ 'string-to-number 'string-to-int))
(provide 'caml-emacs)
;(* *)
;(***********************************************************************)
-;(* $Id: caml-font-old.el 11156 2011-07-27 14:17:02Z doligez $ *)
-
;; useful colors
(cond
+;(***********************************************************************)
+;(* *)
+;(* OCaml *)
+;(* *)
+;(* Jacques Garrigue, Ian T Zimmerman, Damien Doligez *)
+;(* *)
+;(* Copyright 1997 Institut National de Recherche en Informatique et *)
+;(* en Automatique. All rights reserved. This file is distributed *)
+;(* under the terms of the GNU General Public License. *)
+;(* *)
+;(***********************************************************************)
+
;; caml-font: font-lock support for OCaml files
;; now with perfect parsing of comments and strings
(defconst caml-font-ident-re
- "[A-Za-z_\300-\326\330-\366\370-\377][A-Za-z_\300-\326\330-\366\370-\377'0-9]*"
+ (concat "[A-Za-z_\300-\326\330-\366\370-\377]"
+ "[A-Za-z_\300-\326\330-\366\370-\377'0-9]*")
)
(defconst caml-font-int-re
- "\\(0[xX][0-9A-Fa-f][0-9A-Fa-f_]*\\|0[oO][0-7][0-7_]*\\|0[bB][01][01_]*\\)[lLn]?"
+ (concat "\\(0[xX][0-9A-Fa-f][0-9A-Fa-f_]*\\|0[oO][0-7][0-7_]*"
+ "\\|0[bB][01][01_]*\\)[lLn]?")
)
; decimal integers are folded into the RE for floats to get longest-match
; match any char token
(defconst caml-font-char-re
- "'\\(\015\012\\|[^\\']\\|\\(\\\\\\([\\'\"ntbr ]\\|[0-9][0-9][0-9]\\|x[0-9A-Fa-f][0-9A-Fa-f]\\)\\)\\)'"
+ (concat "'\\(\015\012\\|[^\\']\\|"
+ "\\(\\\\\\([\\'\"ntbr ]\\|[0-9][0-9][0-9]"
+ "\\|x[0-9A-Fa-f][0-9A-Fa-f]\\)\\)\\)'")
)
; match a quote followed by a newline
+;;; caml-help.el --- Contextual completion and help to caml-mode
;(***********************************************************************)
;(* *)
;(* OCaml *)
;(* *)
;(***********************************************************************)
-;(* $Id: caml-help.el 11156 2011-07-27 14:17:02Z doligez $ *)
+;; Author: Didier Remy, November 2001.
-;; caml-info.el --- contextual completion and help to caml-mode
+;;; Commentary:
-;; Didier Remy, November 2001.
-
-;; This provides two functions completion and help
-;; look for caml-complete and caml-help
+;; This provides two functions: completion and help.
+;; Look for caml-complete and caml-help.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; - the viewing method and the database, so that the documentation for
;; and identifier could be search in
;; * info / html / man / mli's sources
-;; * viewed in emacs or using an external previewer.
+;; * viewed in Emacs or using an external previewer.
;;
;; Take all identifiers (labels, Constructors, exceptions, etc.)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Code:
(eval-and-compile
- (if (and (boundp 'running-xemacs) running-xemacs)
+ (if (featurep 'xemacs)
(require 'caml-xemacs)
(require 'caml-emacs)))
;; variables to be customized
(defvar ocaml-lib-path 'lazy
- "Path list for ocaml lib sources (mli files)
+ "Path list for ocaml lib sources (mli files).
-'lazy means ask ocaml to find it for your at first use.")
+`lazy' means ask ocaml to find it for your at first use.")
(defun ocaml-lib-path ()
- "Computes if necessary and returns the path for ocaml libs"
+ "Compute if necessary and return the path for ocaml libs."
(if (listp ocaml-lib-path) nil
(setq ocaml-lib-path
(split-string
(concat (downcase (substring s 0 1)) (substring s 1))
s))
-(defun iter (f l) (while (consp l) (apply f (list (car l))) (setq l (cdr l))))
-
(defun ocaml-find-files (path filter &optional depth split)
(let* ((path-string
(if (stringp path)
(if (file-directory-p path) path nil)
- (mapconcat '(lambda (d) (if (file-directory-p d) d))
+ (mapconcat (lambda (d) (if (file-directory-p d) d))
path " ")))
(command
(and path-string
(defvar ocaml-module-alist 'lazy
"A-list of modules with how and where to find help information.
- 'delay means non computed yet")
+`delay' means non computed yet.")
(defun ocaml-add-mli-modules (modules tag &optional path)
(let ((files
modules))
(defun ocaml-add-path (dir &optional path)
- "Extend ocaml-module-alist with modules of DIR relative to PATH"
+ "Extend `ocaml-module-alist' with modules of DIR relative to PATH."
(interactive "D")
(let* ((old (ocaml-lib-path))
(new
(if (file-name-absolute-p dir) dir
(concat
- (or (find-if '(lambda (p) (file-directory-p (concat p "/" dir)))
+ (or (find-if (lambda (p) (file-directory-p (concat p "/" dir)))
(cons default-directory old))
(error "Directory not found"))
"/" dir))))
(ocaml-add-mli-modules (ocaml-module-alist) 'lib new))))
(defun ocaml-module-alist ()
- "Call by need value of variable ocaml-module-alist"
+ "Call by need value of variable `ocaml-module-alist'."
(if (listp ocaml-module-alist)
nil
;; build list of mli files
(defun ocaml-close-module (arg)
"*Close module of name ARG when ARG is a string.
When call interactively, make completion over visible modules.
-Otherwise if ARG is true, close all modules and reset to default. "
+Otherwise if ARG is true, close all modules and reset to default."
(interactive "P")
(if (= (prefix-numeric-value arg) 4)
(setq ocaml-visible-modules 'lazy)
modules))
(if (equal arg "") (setq arg (caar modules))))
(setq ocaml-visible-modules
- (remove-if '(lambda (m) (equal (car m) arg))
+ (remove-if (lambda (m) (equal (car m) arg))
ocaml-visible-modules))
))
(message "%S" (mapcar 'car (ocaml-visible-modules))))
and are nil otherwise.
For debugging purposes, it returns the string Module.entry if called
-with an optional non-nil argument.
-"
+with an optional non-nil argument."
(save-excursion
(let ((module) (entry))
(if (looking-at "[ \n]") (skip-chars-backward " "))
(if (null pattern)
(apply 'append (mapcar 'ocaml-module-symbols list))
(let ((pat (concat "^" (regexp-quote pattern))) (res))
- (iter
- '(lambda (l)
- (iter '(lambda (x)
- (if (string-match pat (car l))
- (if (member x res) nil (setq res (cons x res)))))
- (ocaml-module-symbols l)))
+ (mapc
+ (lambda (l)
+ (mapc (lambda (x)
+ (if (string-match pat (car l))
+ (if (member x res) nil (setq res (cons x res)))))
+ (ocaml-module-symbols l)))
list)
res)
)))
(defvar ocaml-info-prefix "ocaml-lib"
"Prefix of ocaml info files describing library modules.
Suffix .info will be added to info files.
-Additional suffix .gz may be added if info files are compressed.
-")
+Additional suffix .gz may be added if info files are compressed.")
;;
(defun ocaml-hevea-info-add-entries (entries dir name)
of \\[Info-default-directory-list] and the base name \\[ocaml-info-name]
of files to look for.
-This uses info files produced by HeVeA.
-"
+This uses info files produced by HeVeA."
(let ((collect) (seen))
- (iter '(lambda (d)
- (if (member d seen) nil
- (setq collect
- (ocaml-hevea-info-add-entries
- collect d ocaml-info-prefix))
- (setq done (cons d seen))))
+ (mapc (lambda (d)
+ (if (member d seen) nil
+ (setq collect
+ (ocaml-hevea-info-add-entries
+ collect d ocaml-info-prefix))
+ (setq seen (cons d seen))))
Info-directory-list)
collect))
This uses info files produced by ocamldoc."
(require 'info)
(let ((collect) (seen))
- (iter '(lambda (d)
- (if (member d seen) nil
- (setq collect
- (ocaml-ocamldoc-info-add-entries collect d
- ocaml-info-prefix))
- (setq done (cons d seen))))
+ (mapc (lambda (d)
+ (if (member d seen) nil
+ (setq collect
+ (ocaml-ocamldoc-info-add-entries collect d
+ ocaml-info-prefix))
+ (setq seen (cons d seen))))
Info-directory-list)
collect))
nil means do not use info.
- A function to build the list lazily (at the first call). The result of
+ A function to build the list lazily (at the first call). The result of
the function call will be assign permanently to this variable for future
-uses. We provide two default functions \\[ocaml-info-default-function]
-(info produced by HeVeA is the default) and \\[ocaml-info-default-function]
-(info produced by ocamldoc).
+uses. We provide two default functions `ocaml-hevea-info'
+\(info produced by HeVeA is the default) and `ocaml-ocamldoc-info'
+\(info produced by ocamldoc).
Otherwise, this value should be an alist binding module names to info
entries of the form to \"(entry)section\" be taken by the \\[info]
)
(defun ocaml-info-alist ()
- "Call by need value of variable ocaml-info-alist"
+ "Call by need value of variable `ocaml-info-alist'."
(cond
((listp ocaml-info-alist))
((functionp ocaml-info-alist)
;; Help function.
+(defvar view-return-to-alist)
+(defvar view-exit-action)
(defun ocaml-goto-help (&optional module entry same-window)
- "Searches info manual for MODULE and ENTRY in MODULE.
+ "Search info manual for MODULE and ENTRY in MODULE.
If unspecified, MODULE and ENTRY are inferred from the position in the
current buffer using \\[ocaml-qualified-identifier]."
(interactive)
(if (window-live-p window) (select-window window))
))
+(defface ocaml-help-face
+ '((t :background "#88FF44"))
+ "Face to highlight expressions and types.")
+
+(defvar ocaml-help-ovl
+ (let ((ovl (make-overlay 1 1)))
+ (overlay-put ovl 'face 'ocaml-help-face)
+ ovl))
+
(defun caml-help (arg)
"Find documentation for OCaml qualified identifiers.
``Module . entry'' around point using function `ocaml-qualified-identifier'.
If Module is undetermined it is temptatively guessed from the identifier name
-and according to visible modules. If this is still unsucessful, the user is
+and according to visible modules. If this is still unsucessful, the user is
then prompted for a Module name.
The documentation for Module is first seach in the info manual if available,
-then in the ``module.mli'' source file. The entry is then searched in the
+then in the ``module.mli'' source file. The entry is then searched in the
documentation.
Visible modules are computed only once, at the first call.
from the file content.
Prefix arg 4 prompts for Module and identifier instead of guessing values
-from the possition of point in the current buffer.
-"
+from the possition of point in the current buffer."
(interactive "p")
(delete-overlay ocaml-help-ovl)
(let ((module) (entry) (module-entry))
(setq ocaml-links (cons section all))
)))))
-(defvar ocaml-link-map (make-sparse-keymap))
-(define-key ocaml-link-map [mouse-2] 'ocaml-link-goto)
-
-(defvar ocaml-help-ovl (make-overlay 1 1))
-(make-face 'ocaml-help-face)
-(set-face-doc-string 'ocaml-help-face
- "face for hilighting expressions and types")
-(if (not (face-differs-from-default-p 'ocaml-help-face))
- (set-face-background 'ocaml-help-face "#88FF44"))
-(overlay-put ocaml-help-ovl 'face 'ocaml-help-face)
+(defvar ocaml-link-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] 'ocaml-link-goto)
+ map))
(defun ocaml-help-show (arg)
(let ((right (point))
))
(defun ocaml-link-goto (click)
+ "Follow link at point."
(interactive "e")
(let* ((pos (caml-event-point-start click))
(win (caml-event-window click))
(if (window-live-p window) (select-window window))
)))
-(cond
- ((and (x-display-color-p)
- (not (memq 'ocaml-link-face (face-list))))
- (make-face 'ocaml-link-face)
- (set-face-foreground 'ocaml-link-face "Purple")))
+(defface ocaml-link-face
+ '((((class color)) :foreground "Purple"))
+ "Face to highlight hyperlinks.")
(defun ocaml-link-activate (section)
(let ((links (ocaml-info-links section)))
(provide 'caml-help)
+;;; caml-help.el ends here
;(* *)
;(***********************************************************************)
-;(* $Id: caml-hilit.el 12149 2012-02-10 16:15:24Z doligez $ *)
-
; Highlighting patterns for hilit19 under caml-mode
; defined also in caml.el
;(* *)
;(***********************************************************************)
-;(* $Id: caml-types.el 12800 2012-07-30 18:59:07Z doligez $ *)
-
; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt.
;; XEmacs compatibility
type call ident"
)
+(defvar caml-types-position-re nil)
+
(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
(caml-types-number-re "\\([0-9]*\\)"))
(setq caml-types-position-re
caml-types-annotation-date
(not (caml-types-date< caml-types-annotation-date type-date)))
(if (and type-date target-date (caml-types-date< type-date target-date))
- (error (format "`%s' is more recent than `%s'" target-path type-path)))
+ (error (format "`%s' is more recent than `%s'"
+ target-path type-path)))
(message "Reading annotation file...")
(let* ((type-buf (caml-types-find-file type-path))
(tree (with-current-buffer type-buf
;(* *)
;(***********************************************************************)
-;(* $Id: caml-xemacs.el 11156 2011-07-27 14:17:02Z doligez $ *)
-
(require 'overlay)
;; for caml-help.el
;(* *)
;(***********************************************************************)
-;(* $Id: caml.el 12973 2012-09-28 16:54:20Z doligez $ *)
-
;;; caml.el --- OCaml code editing commands for Emacs
;; Xavier Leroy, july 1993.
"Syntax table in use in Caml mode buffers.")
(if caml-mode-syntax-table
()
- (setq caml-mode-syntax-table (make-syntax-table))
- ; backslash is an escape sequence
- (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table)
- ; ( is first character of comment start
- (modify-syntax-entry ?\( "()1n" caml-mode-syntax-table)
- ; * is second character of comment start,
- ; and first character of comment end
- (modify-syntax-entry ?* ". 23n" caml-mode-syntax-table)
- ; ) is last character of comment end
- (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table)
- ; backquote was a string-like delimiter (for character literals)
- ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table)
- ; quote and underscore are part of words
- (modify-syntax-entry ?' "w" caml-mode-syntax-table)
- (modify-syntax-entry ?_ "w" caml-mode-syntax-table)
- ; ISO-latin accented letters and EUC kanjis are part of words
- (let ((i 160))
- (while (< i 256)
- (modify-syntax-entry i "w" caml-mode-syntax-table)
- (setq i (1+ i)))))
+ (let ((n (if (string-match "XEmacs" (emacs-version)) "" "n")))
+ (setq caml-mode-syntax-table (make-syntax-table))
+ ; backslash is an escape sequence
+ (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table)
+ ; ( is first character of comment start
+ (modify-syntax-entry ?\( (concat "()1" n) caml-mode-syntax-table)
+ ; * is second character of comment start,
+ ; and first character of comment end
+ (modify-syntax-entry ?* (concat ". 23" n) caml-mode-syntax-table)
+ ; ) is last character of comment end
+ (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table)
+ ; backquote was a string-like delimiter (for character literals)
+ ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table)
+ ; quote and underscore are part of words
+ (modify-syntax-entry ?' "w" caml-mode-syntax-table)
+ (modify-syntax-entry ?_ "w" caml-mode-syntax-table)
+ ; ISO-latin accented letters and EUC kanjis are part of words
+ (let ((i 160))
+ (while (< i 256)
+ (modify-syntax-entry i "w" caml-mode-syntax-table)
+ (setq i (1+ i))))))
(defvar caml-mode-abbrev-table nil
"Abbrev table used for Caml mode buffers.")
(caml-show-imenu)))
(run-hooks 'caml-mode-hook))
-(defun caml-set-compile-command ()
- "Hook to set compile-command locally, unless there is a Makefile or
- a _build directory or a _tags file in the current directory."
- (interactive)
- (unless (or (null buffer-file-name)
- (file-exists-p "makefile")
- (file-exists-p "Makefile")
- (file-exists-p "_build")
- (file-exists-p "_tags"))
- (let* ((filename (file-name-nondirectory buffer-file-name))
- (basename (file-name-sans-extension filename))
- (command nil))
- (cond
- ((string-match ".*\\.mli\$" filename)
- (setq command "ocamlc -c"))
- ((string-match ".*\\.ml\$" filename)
- (setq command "ocamlc -c") ; (concat "ocamlc -o " basename)
- )
- ((string-match ".*\\.mll\$" filename)
- (setq command "ocamllex"))
- ((string-match ".*\\.mll\$" filename)
- (setq command "ocamlyacc"))
- )
- (if command
- (progn
- (make-local-variable 'compile-command)
- (setq compile-command (concat command " " filename))))
- )))
-(add-hook 'caml-mode-hook 'caml-set-compile-command)
+;; Disabled because it assumes make and does not play well with ocamlbuild.
+;; See PR#4469 for details.
+
+;; (defun caml-set-compile-command ()
+;; "Hook to set compile-command locally, unless there is a Makefile or
+;; a _build directory or a _tags file in the current directory."
+;; (interactive)
+;; (unless (or (null buffer-file-name)
+;; (file-exists-p "makefile")
+;; (file-exists-p "Makefile")
+;; (file-exists-p "_build")
+;; (file-exists-p "_tags"))
+;; (let* ((filename (file-name-nondirectory buffer-file-name))
+;; (basename (file-name-sans-extension filename))
+;; (command nil))
+;; (cond
+;; ((string-match ".*\\.mli\$" filename)
+;; (setq command "ocamlc -c"))
+;; ((string-match ".*\\.ml\$" filename)
+;; (setq command "ocamlc -c") ; (concat "ocamlc -o " basename)
+;; )
+;; ((string-match ".*\\.mll\$" filename)
+;; (setq command "ocamllex"))
+;; ((string-match ".*\\.mll\$" filename)
+;; (setq command "ocamlyacc"))
+;; )
+;; (if command
+;; (progn
+;; (make-local-variable 'compile-command)
+;; (setq compile-command (concat command " " filename))))
+;; )))
+
+;; (add-hook 'caml-mode-hook 'caml-set-compile-command)
+
;;; Auxiliary function. Garrigue 96-11-01.
((looking-at "[ \t]*method")
(setq method-alist (cons index method-alist)))))
;; build menu
- (mapcar
- '(lambda (pair)
- (if (symbol-value (cdr pair))
- (setq menu-alist
- (cons
- (cons (car pair)
- (sort (symbol-value (cdr pair)) 'imenu--sort-by-name))
- menu-alist))))
+ (mapc
+ (lambda (pair)
+ (if (symbol-value (cdr pair))
+ (setq menu-alist
+ (cons
+ (cons (car pair)
+ (sort (symbol-value (cdr pair)) 'imenu--sort-by-name))
+ menu-alist))))
'(("Values" . value-alist)
("Types" . type-alist)
("Modules" . module-alist)
;; In Emacs 19, the regexps in compilation-error-regexp-alist do not
;; match the error messages when the language is not English.
;; Hence we add a regexp.
+;; FIXME do we (still) have i18n of error messages ???
(defconst caml-error-regexp
"^[ A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]"
"Regular expression matching the error messages produced by camlc.")
+;; Newer emacs versions support line/char ranges
+;; We will adapt OCaml to output error messages in a compatible format.
+;; In the meantime we add the new format here in addition to the old one.
+(defconst caml-error-regexp-newstyle
+ (concat "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\),"
+ "char \\([0-9]+\\) to line \\([0-9]+\\), char \\([0-9]+\\):")
+ "Regular expression matching the error messages produced by ocamlc/ocamlopt.")
+
(if (boundp 'compilation-error-regexp-alist)
- (or (assoc caml-error-regexp
- compilation-error-regexp-alist)
- (setq compilation-error-regexp-alist
- (cons (list caml-error-regexp 1 2)
- compilation-error-regexp-alist))))
+ (progn
+ (or (assoc caml-error-regexp
+ compilation-error-regexp-alist)
+ (setq compilation-error-regexp-alist
+ (cons (list caml-error-regexp 1 2)
+ compilation-error-regexp-alist)))
+ (or (assoc caml-error-regexp-newstyle
+ compilation-error-regexp-alist)
+ (setq compilation-error-regexp-alist
+ (cons (list caml-error-regexp-newstyle 1 '(2 . 4) '(3 . 5))
+ compilation-error-regexp-alist)))))
;; A regexp to extract the range info
;(* *)
;(***********************************************************************)
-;(* $Id: camldebug.el 12800 2012-07-30 18:59:07Z doligez $ *)
-
;;; Run camldebug under Emacs
;;; Derived from gdb.el.
;;; gdb.el is Copyright (C) 1988 Free Software Foundation, Inc, and is part
\\[camldebug-display-frame] displays in the other window
the last line referred to in the camldebug buffer.
-\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window,
-call camldebug to step, backstep or next and then update the other window
+\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug
+window,call camldebug to step, backstep or next and then update the other window
with the current file and position.
If you are in a source file, you may select a point to break
camldebug-goto-position
"-[0-9]+[ \t]*\\(before\\).*\n")
camldebug-filter-accumulator)
- (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+-"
+ (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)"
+ "[ \t]+[0-9]+-"
camldebug-goto-position
"[ \t]*\\(after\\).*\n")
camldebug-filter-accumulator)))
;;; Miscellaneous.
(defun camldebug-module-name (filename)
- (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1)))
+ (substring filename (string-match "\\([^/]*\\)\\.ml$" filename)
+ (match-end 1)))
;;; The camldebug-call function must do the right thing whether its
;;; invoking keystroke is from the camldebug buffer itself (via
;(* *)
;(***********************************************************************)
-;(* $Id: inf-caml.el 12149 2012-02-10 16:15:24Z doligez $ *)
-
;;; inf-caml.el --- run the OCaml toplevel in an Emacs buffer
;; Xavier Leroy, july 1993.
(column (- (match-end 3) (match-beginning 3)))
(width (- (match-end 2) (match-end 3))))
(if (string-match "^\\(.*\\)[<]EOF[>]$" expr)
- (setq expr (substring expr (match-beginning 1) (match-end 1))))
+ (setq expr (substring expr (match-beginning 1)
+ (match-end 1))))
(switch-to-buffer buf)
(re-search-backward
(concat "^" (regexp-quote expr) "$")
;(* *)
;(***********************************************************************)
-;(* $Id: ocamltags.in 12800 2012-07-30 18:59:07Z doligez $ *)
-
;; Copyright (C) 1998 Ian Zimmerman <itz@transbay.net>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
-;; $Id: ocamltags.in 12800 2012-07-30 18:59:07Z doligez $
(require 'caml)
lexer.cmi cset.cmi compact.cmi common.cmi
main.cmx : syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx \
lexer.cmx cset.cmx compact.cmx common.cmx
-output.cmo : syntax.cmi lexgen.cmi compact.cmi common.cmi output.cmi
-output.cmx : syntax.cmx lexgen.cmx compact.cmx common.cmx output.cmi
-outputbis.cmo : syntax.cmi lexgen.cmi common.cmi outputbis.cmi
-outputbis.cmx : syntax.cmx lexgen.cmx common.cmx outputbis.cmi
+output.cmo : lexgen.cmi compact.cmi common.cmi output.cmi
+output.cmx : lexgen.cmx compact.cmx common.cmx output.cmi
+outputbis.cmo : lexgen.cmi common.cmi outputbis.cmi
+outputbis.cmx : lexgen.cmx common.cmx outputbis.cmi
parser.cmo : syntax.cmi cset.cmi parser.cmi
parser.cmx : syntax.cmx cset.cmx parser.cmi
syntax.cmo : cset.cmi syntax.cmi
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
# The lexer generator
CAMLC=../boot/ocamlrun ../boot/ocamlc -strict-sequence -nostdlib -I ../boot
CAMLOPT=../boot/ocamlrun ../ocamlopt -nostdlib -I ../stdlib
-COMPFLAGS=-warn-error A
+COMPFLAGS=-w +33..39 -warn-error A
CAMLYACC=../boot/ocamlyacc
YACCFLAGS=-v
CAMLLEX=../boot/ocamlrun ../boot/ocamllex
CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
+OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \
+ compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
all: ocamllex
allopt: ocamllex.opt
ocamllex: $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS)
+ $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamllex $(OBJS)
ocamllex.opt: $(OBJS:.cmo=.cmx)
$(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx)
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
# The lexer generator
include ../config/Makefile
CAMLDEP=../boot/ocamlrun ../tools/ocamldep
DEPFLAGS=
-OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
+OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \
+ compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
all: ocamllex syntax.cmo
allopt: ocamllex.opt
ocamllex: $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS)
+ $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamllex $(OBJS)
ocamllex.opt: $(OBJS:.cmo=.cmx)
$(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx)
done
let copy_chars_win32 ic oc start stop =
- for i = start to stop - 1 do
+ for _i = start to stop - 1 do
let c = input_char ic in
if c <> '\r' then output_char oc c
done
"Win32" | "Cygwin" -> copy_chars_win32
| _ -> copy_chars_unix
-let copy_chunk sourcefile ic oc trl loc add_parens =
+let copy_chunk ic oc trl loc add_parens =
if loc.start_pos < loc.end_pos || add_parens then begin
- fprintf oc "# %d \"%s\"\n" loc.start_line sourcefile;
+ fprintf oc "# %d \"%s\"\n" loc.start_line loc.loc_file;
if add_parens then begin
- for i = 1 to loc.start_col - 1 do output_char oc ' ' done;
+ for _i = 1 to loc.start_col - 1 do output_char oc ' ' done;
output_char oc '(';
end else begin
- for i = 1 to loc.start_col do output_char oc ' ' done;
+ for _i = 1 to loc.start_col do output_char oc ' ' done;
end;
seek_in ic loc.start_pos;
copy_chars ic oc loc.start_pos loc.end_pos;
| Sum (a,i) ->
fprintf oc "(%a + %d)" output_base_mem a i
-let output_env sourcefile ic oc tr env =
+let output_env ic oc tr env =
let pref = ref "let" in
match env with
| [] -> ()
List.iter
(fun ((x,pos),v) ->
fprintf oc "%s\n" !pref ;
- copy_chunk sourcefile ic oc tr pos false ;
+ copy_chunk ic oc tr pos false ;
begin match v with
| Ident_string (o,nstart,nend) ->
fprintf oc
val open_tracker : string -> out_channel -> line_tracker
val close_tracker : line_tracker -> unit
val copy_chunk :
- string ->
in_channel -> out_channel -> line_tracker -> Syntax.location -> bool -> unit
val output_mem_access : out_channel -> int -> unit
val output_memory_actions :
string -> out_channel -> Lexgen.memory_action list -> unit
val output_env :
- string -> in_channel -> out_channel -> line_tracker ->
+ in_channel -> out_channel -> line_tracker ->
(Lexgen.ident * Lexgen.ident_info) list -> unit
val output_args : out_channel -> string list -> unit
(* *)
(***********************************************************************)
-(* $Id: compact.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Compaction of an automata *)
open Lexgen
(* *)
(***********************************************************************)
-(* $Id: compact.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Compaction of an automata *)
type lex_tables =
{ tbl_base: int array; (* Perform / Shift *)
(* *)
(***********************************************************************)
-(* $Id: cset.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-
exception Bad
type t = (int * int) list
(* *)
(***********************************************************************)
-(* $Id: cset.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Set of characters encoded as list of intervals *)
type t
(* *)
(***********************************************************************)
-(* $Id: lexer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
val main: Lexing.lexbuf -> Parser.token
exception Lexical_error of string * string * int * int
(* *)
(***********************************************************************)
-(* $Id: lexer.mll 12418 2012-05-02 14:41:30Z doligez $ *)
-
(* The lexical analyzer for lexer definitions. Bootstrapped! *)
{
}
| '{'
{ let p = Lexing.lexeme_end_p lexbuf in
+ let f = p.Lexing.pos_fname in
let n1 = p.Lexing.pos_cnum
and l1 = p.Lexing.pos_lnum
and s1 = p.Lexing.pos_bol in
brace_depth := 1;
let n2 = handle_lexical_error action lexbuf in
- Taction({start_pos = n1; end_pos = n2;
+ Taction({loc_file = f; start_pos = n1; end_pos = n2;
start_line = l1; start_col = n1 - s1}) }
| '=' { Tequal }
| '|' { Tor }
(* *)
(***********************************************************************)
-(* $Id: lexgen.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Compiling a lexer definition *)
open Syntax
(* A lot of sets and map structures *)
-module Ints = Set.Make(struct type t = int let compare = compare end)
+module Ints =
+ Set.Make(struct type t = int let compare (x:t) y = compare x y end)
let id_compare (id1,_) (id2,_) = String.compare id1 id2
chars_count := 0;
let entry_list =
List.map
- (fun {name=entry_name ; args=args ; shortest=shortest ; clauses= casedef} ->
+ (fun {name=entry_name; args=args; shortest=shortest; clauses=casedef} ->
let (re,actions,_,ntags) = encode_casedef casedef in
{ lex_name = entry_name;
lex_regexp = re;
Extension to tagged automata.
Confer
Ville Larikari
- ``NFAs with Tagged Transitions, their Conversion to Deterministic
- Automata and Application to Regular Expressions''.
+ 'NFAs with Tagged Transitions, their Conversion to Deterministic
+ Automata and Application to Regular Expressions'.
Symposium on String Processing and Information Retrieval (SPIRE 2000),
http://kouli.iki.fi/~vlaurika/spire2000-tnfa.ps
(See also)
fill s r2
| Star r ->
fill (TransSet.union (firstpos r) s) r in
- List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp) entry_list ;
+ List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp)
+ entry_list;
v
(************************)
module MemMap =
- Map.Make (struct type t = int let compare = Pervasives.compare end)
+ Map.Make (struct type t = int
+ let compare (x:t) y = Pervasives.compare x y end)
type 'a dfa_state =
{final : int * ('a * int TagMap.t) ;
(* *)
(***********************************************************************)
-(* $Id: lexgen.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
-
(* raised when there are too many bindings (>= 254 memory cells) *)
exception Memory_overflow
(* *)
(***********************************************************************)
-(* $Id: main.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The lexer generator. Command-line parsing. *)
open Syntax
-open Lexgen
let ml_automata = ref false
let source_name = ref None
let specs =
["-ml", Arg.Set ml_automata,
- " Output code that does not use the Lexing module built-in automata interpreter";
+ " Output code that does not use the Lexing module built-in automata \
+ interpreter";
"-o", Arg.String (fun x -> output_name := Some x),
" <file> Set output file name to <file>";
"-q", Arg.Set Common.quiet_mode, " Do not display informational messages";
(* *)
(***********************************************************************)
-(* $Id: output.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Output the DFA tables and its entry points *)
open Printf
-open Syntax
open Lexgen
open Compact
open Common
(fun (num, env, loc) ->
fprintf oc " | ";
fprintf oc "%d ->\n" num;
- output_env sourcefile ic oc oci env;
- copy_chunk sourcefile ic oc oci loc true;
+ output_env ic oc oci env;
+ copy_chunk ic oc oci loc true;
fprintf oc "\n")
e.auto_actions;
fprintf oc " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; \
- __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n"
+ __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n"
e.auto_name output_args e.auto_args
(* Main output function *)
Printf.printf "%d additional bytes used for bindings\n" size_groups ;
flush stdout;
if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
- copy_chunk sourcefile ic oc oci header false;
+ copy_chunk ic oc oci header false;
output_tables oc tables;
begin match entry_points with
[] -> ()
entries;
output_string oc ";;\n\n";
end;
- copy_chunk sourcefile ic oc oci trailer false
+ copy_chunk ic oc oci trailer false
(* *)
(***********************************************************************)
-(* $Id: output.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Output the DFA tables and its entry points *)
val output_lexdef:
(* *)
(***********************************************************************)
-(* $Id: outputbis.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Output the DFA tables and its entry points *)
open Printf
-open Syntax
open Lexgen
open Common
\n let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in\
\n lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\
\n lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\
-\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};\
+\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos+lexbuf.Lexing.lex_curr_pos};\
\n match __ocaml_lex_result with\n"
e.auto_name output_args e.auto_args
e.auto_mem_size (output_memory_actions " ") init_moves init_num ;
(fun (num, env, loc) ->
fprintf oc " | ";
fprintf oc "%d ->\n" num;
- output_env sourcefile ic oc tr env ;
- copy_chunk sourcefile ic oc tr loc true;
+ output_env ic oc tr env ;
+ copy_chunk ic oc tr loc true;
fprintf oc "\n")
e.auto_actions;
fprintf oc " | _ -> raise (Failure \"lexing: empty token\")\n\n\n"
let output_lexdef sourcefile ic oc tr header entry_points transitions trailer =
- copy_chunk sourcefile ic oc tr header false;
+ copy_chunk ic oc tr header false;
output_automata oc transitions ;
begin match entry_points with
[] -> ()
entries;
output_string oc ";;\n\n";
end;
- copy_chunk sourcefile ic oc tr trailer false
+ copy_chunk ic oc tr trailer false
(* *)
(***********************************************************************)
-(* $Id: outputbis.mli 11156 2011-07-27 14:17:02Z doligez $ *)
val output_lexdef :
string ->
in_channel ->
/* */
/***********************************************************************/
-/* $Id: parser.mly 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The grammar for lexer definitions */
%{
%token <int> Tchar
%token <string> Tstring
%token <Syntax.location> Taction
-%token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket
+%token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof
+ Tlbracket Trbracket
%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Tsharp
%right Tas
Taction
{ $1 }
| /*epsilon*/
- { { start_pos = 0; end_pos = 0; start_line = 1; start_col = 0 } }
+ { { loc_file = ""; start_pos = 0; end_pos = 0; start_line = 1;
+ start_col = 0 } }
;
named_regexps:
named_regexps Tlet Tident Tequal regexp
{let p1 = Parsing.rhs_start_pos 3
and p2 = Parsing.rhs_end_pos 3 in
let p = {
+ loc_file = p1.Lexing.pos_fname ;
start_pos = p1.Lexing.pos_cnum ;
end_pos = p2.Lexing.pos_cnum ;
start_line = p1.Lexing.pos_lnum ;
(* *)
(***********************************************************************)
-(* $Id: syntax.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-(* This apparently useless implmentation file is in fact required
+(* This apparently useless implementation file is in fact required
by the pa_ocamllex syntax extension *)
(* The shallow abstract syntax *)
-type location =
- { start_pos: int;
- end_pos: int;
- start_line: int;
- start_col: int }
+type location = {
+ loc_file : string;
+ start_pos : int;
+ end_pos : int;
+ start_line : int;
+ start_col : int;
+}
type regular_expression =
Epsilon
(* *)
(***********************************************************************)
-(* $Id: syntax.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The shallow abstract syntax *)
-type location =
- { start_pos: int;
- end_pos: int;
- start_line: int;
- start_col: int }
+type location = {
+ loc_file : string;
+ start_pos : int;
+ end_pos : int;
+ start_line : int;
+ start_col : int;
+}
type regular_expression =
Epsilon
# #
#########################################################################
-# $Id: Makefile 12246 2012-03-16 15:53:07Z doligez $
-
include ../config/Makefile
DIR=$(MANDIR)/man$(MANEXT)
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocaml.m 12086 2012-01-27 12:50:31Z doligez $
-.\"
.TH OCAML 1
.SH NAME
The following command-line options are recognized by
.BR ocaml (1).
.TP
+.B \-absname
+Show absolute filenames in error messages.
+.TP
.BI \-I \ directory
Add the given directory to the list of directories searched for
source and compiled files. By default, the current directory is
Labels are not ignored in types, labels may be used in applications,
and labelled parameters can be given in any order. This is the default.
.TP
+.B \-no\-app\-funct
+Deactivates the applicative behaviour of functors. With this option,
+each functor application generates new types in its result and
+applying the same functor twice to the same argument yields two
+incompatible structures.
+.TP
.B \-noassert
Do not compile assertion checks. Note that the special form
.B assert\ false
Do not include the standard library directory in the list of
directories searched for source and compiled files.
.TP
+.BI \-ppx \ command
+After parsing, pipe the abstract syntax tree through the preprocessor
+.IR command .
+The format of the input and ouput of the preprocessor
+are not yet documented.
+.TP
.B \-principal
Check information path during type-checking, to make sure that all
types are derived in a principal way. When using labelled arguments
only recursive types where the recursion goes through an object type
are supported.
.TP
+.B \-short\-paths
+When a type is visible under several module-paths, use the shortest
+one when printing the type's name in inferred interfaces and error and
+warning messages.
+.TP
+.B \-stdin
+Read the standard input as a script file rather than starting an
+interactive session.
+.TP
+.B \-strict\-sequence
+Force the left-hand part of each sequence to have type unit.
+.TP
.B \-unsafe
Turn bound checking off on array and string accesses (the
.BR v.(i) and s.[i]
argument.
.TP
.BI \-warn-error \ warning-list
-Treat as errors the warnings described by the argument
+Mark as fatal the warnings described by the argument
.IR warning\-list .
-Note that a warning is not triggered (and not treated as error) if
+Note that a warning is not triggered (and does not trigger an error) if
it is disabled by the
.B \-w
option. See
.I warning\-list
argument.
.TP
+.B \-warn\-help
+Show the description of all available warning numbers.
+.TP
+.BI \- \ file
+Use
+.I file
+as a script file name, even when it starts with a hyphen (-).
+.TP
.BR \-help \ or \ \-\-help
Display a short usage summary and exit.
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlc.m 12800 2012-07-30 18:59:07Z doligez $
-.\"
.TH OCAMLC 1
.SH NAME
.B -noautolink
option is given.
.TP
+.B \-absname
+Show absolute filenames in error messages.
+.TP
.B \-annot
Dump detailed information about the compilation (types, bindings,
tail-calls, etc). The information for file
.B emacs/caml\-types.el
to display types and other annotations interactively.
.TP
-.B \-dtypes
-Has been deprecated. Please use
-.B \-annot
-instead.
+.B \-bin\-annot
+Dump detailed information about the compilation (types, bindings,
+tail-calls, etc) in binary format. The information for file
+.IR src .ml
+is put into file
+.IR src .cmt.
+In case of a type error, dump
+all the information inferred by the type-checker before the error.
+The annotation files produced by
+.B \-bin\-annot
+contain more information
+and are much more compact than the files produced by
+.BR \-annot .
.TP
.B \-c
Compile only. Suppress the linking phase of the
.B \-custom
option). This causes the given C library to be linked with the program.
.TP
-.B \-ccopt
-Pass the given option to the C compiler and linker, when linking in
+.BI \-ccopt \ option
+Pass the given
+.I option
+to the C compiler and linker, when linking in
"custom runtime" mode (see the
.B \-custom
option). For instance,
directory
.IR dir .
.TP
+.B \-compat\-32
+Check that the generated bytecode executable can run on 32-bit
+platforms and signal an error if it cannot. This is useful when
+compiling bytecode on a 64-bit machine.
+.TP
.B \-config
Print the version number of
.BR ocamlc (1)
.BR ocamlrun (1)
can find it and use it.
.TP
+.BI \-for\-pack \ ident
+This option is accepted for compatibility with
+.BR ocamlopt (1)
+; it does nothing.
+.TP
.B \-g
Add debugging information while compiling and linking. This option is
required in order to be able to debug the program with
.B ocamlc\ \-use\-runtime
.IR runtime-name .
.TP
+.B \-no\-app\-funct
+Deactivates the applicative behaviour of functors. With this option,
+each functor application generates new types in its result and
+applying the same functor twice to the same argument yields two
+incompatible structures.
+.TP
.B \-noassert
Do not compile assertion checks. Note that the special form
.B assert\ false
Ignore non-optional labels in types. Labels cannot be used in
applications, and parameter order becomes strict.
.TP
+.B \-nostdlib
+Do not include the standard library directory in the list of
+directories searched for compiled interfaces (see option
+.B \-I
+).
+.TP
.BI \-o \ exec\-file
Specify the name of the output file produced by the linker. The
default output name is
extension .ppi for an interface (.mli) file and .ppo for an
implementation (.ml) file.
.TP
+.BI \-ppx \ command
+After parsing, pipe the abstract syntax tree through the preprocessor
+.IR command .
+The format of the input and ouput of the preprocessor
+are not yet documented.
+.TP
.B \-principal
Check information path during type-checking, to make sure that all
types are derived in a principal way. When using labelled arguments
.B d
suffix is supported and gives a debug version of the runtime.
.TP
+.B \-short\-paths
+When a type is visible under several module-paths, use the shortest
+one when printing the type's name in inferred interfaces and error and
+warning messages.
+.TP
.B \-strict\-sequence
-The left-hand part of a sequence must have type unit.
+Force the left-hand part of each sequence to have type unit.
.TP
.B \-thread
Compile or link multithreaded programs, in combination with the
.B \-custom
mode. Useful to debug C library problems.
.TP
-.BR \-vnum \ or\ \-version
-Print the version number of the compiler in short form (e.g. "3.11.0"),
-then exit.
-.TP
.B \-vmthread
Compile or link multithreaded programs, in combination with the
VM-level threads library described in
.IR The\ OCaml\ user's\ manual .
.TP
+.BR \-vnum \ or\ \-version
+Print the version number of the compiler in short form (e.g. "3.11.0"),
+then exit.
+.TP
.BI \-w \ warning\-list
-Enable, disable, or mark as errors the warnings specified by the argument
+Enable, disable, or mark as fatal the warnings specified by the argument
.IR warning\-list .
Each warning can be
.IR enabled \ or\ disabled ,
and each warning can be
-.I marked
-(as error) or
-.IR unmarked .
+.IR fatal or
+.IR non-fatal .
If a warning is disabled, it isn't displayed and doesn't affect
-compilation in any way (even if it is marked). If a warning is enabled,
+compilation in any way (even if it is fatal). If a warning is enabled,
it is displayed normally by the compiler whenever the source code
-triggers it. If it is enabled and marked, the compiler will stop with
-an error after displaying the warnings if the source code triggers it.
+triggers it. If it is enabled and fatal, the compiler will also stop
+with an error after displaying it.
The
.I warning\-list
.IR num .
.BI @ num
-\ \ Enable and mark warning number
+\ \ Enable and mark as fatal warning number
.IR num .
.BI + num1 .. num2
(inclusive).
.BI @ num1 .. num2
-\ \ Enable and mark all warnings between
+\ \ Enable and mark as fatal all warnings between
.I num1
and
.I num2
The letter may be uppercase or lowercase.
.BI @ letter
-\ \ Enable and mark the set of warnings corresponding to
+\ \ Enable and mark as fatal the set of warnings corresponding to
.IR letter .
The letter may be uppercase or lowercase.
\ \ \ Suspicious-looking end-of-comment mark.
3
-\ \ \ Deprecated syntax.
+\ \ \ Deprecated feature.
4
\ \ \ Fragile pattern matching: matching that will remain
\ \ A non-escaped end-of-line was found in a string constant. This may
cause portability problems between Unix and Windows.
+30
+\ \ Two labels or constructors of the same name are defined in two
+mutually recursive types.
+
+31
+\ \ A module is linked twice in the same executable.
+
+32
+\ \ Unused value declaration.
+
+33
+\ \ Unused open statement.
+
+34
+\ \ Unused type declaration.
+
+35
+\ \ Unused for-loop index.
+
+36
+\ \ Unused ancestor variable.
+
+37
+\ \ Unused constructor.
+
+38
+\ \ Unused exception constructor.
+
+39
+\ \ Unused rec flag.
+
+40
+\ \ Constructor or label name used out of scope.
+
+41
+\ \ Ambiguous constructor or label name.
+
+42
+\ \ Disambiguated constructor or label name.
+
+43
+\ \ Nonoptional label applied as optional.
+
+44
+\ \ Open statement shadows an already defined identifier.
+
+45
+\ \ Open statement shadows an already defined label or constructor.
+
The letters stand for the following sets of warnings. Any letter not
mentioned here corresponds to the empty set.
\ 5
.B K
-\ 32, 33, 34, 35, 36, 37
+\ 32, 33, 34, 35, 36, 37, 38, 39
.B L
\ 6
.IP
The default setting is
-.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39 .
+.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45 .
Note that warnings
.BR 5 \ and \ 10
are not always triggered, depending on the internals of the type checker.
.B \-w
option: a
.B +
-sign (or an uppercase letter) turns the corresponding warnings into errors, a
+sign (or an uppercase letter) marks the corresponding warnings as fatal, a
.B \-
-sign (or a lowercase letter) turns them back into warnings, and a
+sign (or a lowercase letter) turns them back into non-fatal warnings, and a
.B @
-sign both enables and marks the corresponding warnings.
+sign both enables and marks as fatal the corresponding warnings.
Note: it is not recommended to use the
.B \-warn\-error
warnings.
The default setting is
-.B \-warn\-error\ -a
-(none of the warnings is treated as an error).
+.B \-warn\-error\ -a (all warnings are non-fatal).
+.TP
+.B \-warn\-help
+Show the description of all available warning numbers.
.TP
.B \-where
Print the location of the standard library, then exit.
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlcp.m 12429 2012-05-03 17:23:51Z doligez $
-.\"
.TH "OCAMLCP" 1
.SH NAME
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamldebug.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLDEBUG 1
.SH NAME
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamldep.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLDEP 1
.SH NAME
The following command-line options are recognized by
.BR ocamldep (1).
.TP
+.B \-absname
+Show absolute filenames in error messages.
+.TP
.BI \-I \ directory
Add the given directory to the list of directories searched for
source files. If a source file foo.ml mentions an external
.I command
as a preprocessor for each source file.
.TP
+.BI \-ppx \ command
+Pipe abstract syntax tree through preprocessor
+.IR command .
+.TP
.B \-slash
Under Unix, this option does nothing.
.TP
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamldoc.m 12800 2012-07-30 18:59:07Z doligez $
-.\"
.TH OCAMLDOC 1
\" .de Sh \" Subsection heading
Pipe sources through preprocessor
.IR command .
.TP
+.BI \-ppx \ command
+Pipe abstract syntax tree through preprocessor
+.IR command .
+.TP
.B \-sort
Sort the list of top-level modules before generating the documentation.
.TP
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamllex.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLLEX 1
.SH NAME
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlmktop.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLMKTOP 1
.SH NAME
.B \-v
Print the version string of the compiler and exit.
.TP
-.BR \-vnum or \-version
+.BR \-vnum \ or\ \-version
Print the version number of the compiler in short form and exit.
.TP
.BI \-cclib\ \-l libname
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlopt.m 12800 2012-07-30 18:59:07Z doligez $
-.\"
.TH OCAMLOPT 1
.SH NAME
.B \-noautolink
option is given.
.TP
+.B \-absname
+Show absolute filenames in error messages.
+.TP
.B \-annot
Dump detailed information about the compilation (types, bindings,
tail-calls, etc). The information for file
.B emacs/caml\-types.el
to display types and other annotations interactively.
.TP
-.B \-dtypes
-Has been deprecated. Please use
-.BI \-annot
-instead.
+.B \-bin\-annot
+Dump detailed information about the compilation (types, bindings,
+tail-calls, etc) in binary format. The information for file
+.IR src .ml
+is put into file
+.IR src .cmt.
+In case of a type error, dump
+all the information inferred by the type-checker before the error.
+The annotation files produced by
+.B \-bin\-annot
+contain more information
+and are much more compact than the files produced by
+.BR \-annot .
.TP
.B \-c
Compile only. Suppress the linking phase of the
.B labltk
of the standard library to the search path.
.TP
+.BI \-impl \ filename
+Compile the file
+.I filename
+as an implementation file, even if its extension is not .ml.
+.TP
.BI \-inline \ n
Set aggressiveness of inlining to
.IR n ,
subsequent links of programs involving that library to link all the
modules contained in the library.
.TP
+.B \-no\-app\-funct
+Deactivates the applicative behaviour of functors. With this option,
+each functor application generates new types in its result and
+applying the same functor twice to the same argument yields two
+incompatible structures.
+.TP
.B \-noassert
Do not compile assertion checks. Note that the special form
.B assert\ false
an intermediate file, which is compiled. If there are no compilation
errors, the intermediate file is deleted afterwards.
.TP
+.BI \-ppx \ command
+After parsing, pipe the abstract syntax tree through the preprocessor
+.IR command .
+The format of the input and ouput of the preprocessor
+are not yet documented.
+.TP
.B \-principal
Check information path during type-checking, to make sure that all
types are derived in a principal way. All programs accepted in
apply to the way the extra native objects have been compiled (under
Linux AMD 64, they must contain only position-independent code).
.TP
+.B \-short\-paths
+When a type is visible under several module-paths, use the shortest
+one when printing the type's name in inferred interfaces and error and
+warning messages.
+.TP
.B \-strict\-sequence
The left-hand part of a sequence must have type unit.
.TP
then exit.
.TP
.BI \-w \ warning\-list
-Enable, disable, or mark as errors the warnings specified by the argument
+Enable, disable, or mark as fatal the warnings specified by the argument
.IR warning\-list .
See
.BR ocamlc (1)
.IR warning-list .
.TP
.BI \-warn\-error \ warning\-list
-Mark as errors the warnings specified in the argument
+Mark as fatal the warnings specified in the argument
.IR warning\-list .
The compiler will stop with an error when one of these
warnings is emitted. The
.B \-w
option: a
.B +
-sign (or an uppercase letter) turns the corresponding warnings into errors, a
+sign (or an uppercase letter) marks the corresponding warnings as fatal, a
.B \-
-sign (or a lowercase letter) turns them back into warnings, and a
+sign (or a lowercase letter) turns them back into non-fatal warnings, and a
.B @
-sign both enables and marks the corresponding warnings.
+sign both enables and marks as fatal the corresponding warnings.
Note: it is not recommended to use the
.B \-warn\-error
warnings.
The default setting is
-.B \-warn\-error\ -a
-(none of the warnings is treated as an error).
+.B \-warn\-error\ -a (all warnings are non-fatal).
+.TP
+.B \-warn\-help
+Show the description of all available warning numbers.
+.TP
.TP
.B \-where
Print the location of the standard library, then exit.
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlprof.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLPROF 1
.SH NAME
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlrun.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLRUN 1
.SH NAME
A parameter specification is an option letter followed by an =
sign, a decimal number (or a hexadecimal number prefixed by
.BR 0x ),
-and an optional multiplier. There are nine options, six of which
-correspond to the fields of the
+and an optional multiplier. The options are documented below; the
+last six correspond to the fields of the
.B control
record documented in
.IR "The OCaml user's manual",
the pushdown automaton that executes the parsers prints a
trace of its actions. This option takes no argument.
.TP
+.BR R
+Turn on randomization of all hash tables by default (see the
+.B Hashtbl
+module of the standard library). This option takes no
+argument.
+.TP
+.BR h
+The initial size of the major heap (in words).
+.TP
.BR a \ (allocation_policy)
The policy used for allocating in the OCaml heap. Possible values
are 0 for the next-fit policy, and 1 for the first-fit
-policy. Next-fit is somewhat faster, but first-fit is better for
+policy. Next-fit is usually faster, but first-fit is better for
avoiding fragmentation and the associated heap compactions.
.TP
.BR s \ (minor_heap_size)
.BR l \ (stack_limit)
The limit (in words) of the stack size.
.TP
-.BR h
-The initial size of the major heap (in words).
-.TP
.BR v \ (verbose)
What GC messages to print to stderr. This is a sum of values selected
from the following:
The multiplier is
.BR k ,
-.BR M \ or
+.BR M ,\ or
.BR G ,
for multiplication by 2^10, 2^20, and 2^30 respectively.
For example, on a 32-bit machine under bash, the command
.\"* *
.\"***********************************************************************
.\"
-.\" $Id: ocamlyacc.m 11156 2011-07-27 14:17:02Z doligez $
-.\"
.TH OCAMLYACC 1
.SH NAME
(* *)
(***********************************************************************)
-(* $Id: myocamlbuild.ml 12032 2012-01-17 21:47:36Z lefessan $ *)
-
open Ocamlbuild_plugin
open Command
open Arch
let windows = Sys.os_type = "Win32";;
if windows then tag_any ["windows"];;
let ccomptype = C.ccomptype
-let () = if ccomptype <> "cc" then eprintf "ccomptype: %s@." ccomptype;;
+(*let () = if ccomptype <> "cc" then eprintf "ccomptype: %s@." ccomptype;;*)
let fp_cat oc f = with_input_file ~bin:true f (fun ic -> copy_chan ic oc)
let camlp4_arch =
dir "" [
- dir "stdlib" [];
dir "camlp4" [
dir "build" [];
dir_pack "Camlp4" [
Pathname.define_context "" ["stdlib"];;
Pathname.define_context "utils" [Pathname.current_dir_name; "stdlib"];;
-Pathname.define_context "camlp4" ["camlp4"; "stdlib"];;
-Pathname.define_context "camlp4/boot" ["camlp4"; "stdlib"];;
+Pathname.define_context "camlp4/boot" ["camlp4"];;
Pathname.define_context "camlp4/Camlp4Parsers" ["camlp4"; "stdlib"];;
Pathname.define_context "camlp4/Camlp4Printers" ["camlp4"; "stdlib"];;
Pathname.define_context "camlp4/Camlp4Filters" ["camlp4"; "stdlib"];;
Pathname.define_context "otherlibs/dynlink" ["otherlibs/dynlink"; "bytecomp"; "utils"; "typing"; "parsing"; "stdlib"];;
Pathname.define_context "otherlibs/dynlink/nat" ["otherlibs/dynlink/nat"; "asmcomp"; "stdlib"];;
Pathname.define_context "asmcomp" ["asmcomp"; "bytecomp"; "parsing"; "typing"; "utils"; "stdlib"];;
-Pathname.define_context "ocamlbuild" ["ocamlbuild"; "stdlib"; "."];;
+Pathname.define_context "ocamlbuild" ["ocamlbuild"; "."];;
Pathname.define_context "lex" ["lex"; "stdlib"];;
List.iter (fun x -> let x = "otherlibs"/x in Pathname.define_context x [x; "stdlib"])
--- /dev/null
+bool.cmi :
+command.cmi : tags.cmi signatures.cmi
+configuration.cmi : tags.cmi pathname.cmi
+digest_cache.cmi :
+discard_printf.cmi :
+display.cmi : tags.cmi
+exit_codes.cmi :
+fda.cmi : slurp.cmi
+findlib.cmi : signatures.cmi command.cmi
+flags.cmi : tags.cmi command.cmi
+glob.cmi : signatures.cmi glob_ast.cmi bool.cmi
+glob_ast.cmi : bool.cmi
+glob_lexer.cmi : glob_ast.cmi
+hooks.cmi :
+hygiene.cmi : slurp.cmi
+lexers.cmi : glob.cmi
+log.cmi : tags.cmi signatures.cmi
+main.cmi :
+my_std.cmi : signatures.cmi
+my_unix.cmi :
+ocaml_arch.cmi : signatures.cmi command.cmi
+ocaml_compiler.cmi : tags.cmi rule.cmi pathname.cmi command.cmi
+ocaml_dependencies.cmi : pathname.cmi
+ocaml_specific.cmi :
+ocaml_tools.cmi : tags.cmi rule.cmi pathname.cmi command.cmi
+ocaml_utils.cmi : tags.cmi pathname.cmi command.cmi
+ocamlbuild.cmi :
+ocamlbuild_executor.cmi :
+ocamlbuild_plugin.cmi :
+ocamlbuild_unix_plugin.cmi :
+ocamlbuild_where.cmi :
+ocamlbuildlight.cmi :
+options.cmi : slurp.cmi signatures.cmi command.cmi
+param_tags.cmi : tags.cmi
+pathname.cmi : signatures.cmi
+plugin.cmi :
+ppcache.cmi :
+report.cmi : solver.cmi
+resource.cmi : slurp.cmi pathname.cmi my_std.cmi command.cmi
+rule.cmi : tags.cmi resource.cmi pathname.cmi my_std.cmi command.cmi
+shell.cmi :
+signatures.cmi :
+slurp.cmi : my_unix.cmi
+solver.cmi : pathname.cmi
+tags.cmi : signatures.cmi
+tools.cmi : tags.cmi pathname.cmi
+bool.cmo : bool.cmi
+bool.cmx : bool.cmi
+command.cmo : tags.cmi shell.cmi param_tags.cmi my_unix.cmi my_std.cmi \
+ log.cmi lexers.cmi command.cmi
+command.cmx : tags.cmx shell.cmx param_tags.cmx my_unix.cmx my_std.cmx \
+ log.cmx lexers.cmi command.cmi
+configuration.cmo : tags.cmi param_tags.cmi my_std.cmi log.cmi lexers.cmi \
+ glob.cmi configuration.cmi
+configuration.cmx : tags.cmx param_tags.cmx my_std.cmx log.cmx lexers.cmi \
+ glob.cmx configuration.cmi
+digest_cache.cmo : shell.cmi pathname.cmi options.cmi my_unix.cmi my_std.cmi \
+ digest_cache.cmi
+digest_cache.cmx : shell.cmx pathname.cmx options.cmx my_unix.cmx my_std.cmx \
+ digest_cache.cmi
+discard_printf.cmo : discard_printf.cmi
+discard_printf.cmx : discard_printf.cmi
+display.cmo : tags.cmi my_unix.cmi my_std.cmi discard_printf.cmi display.cmi
+display.cmx : tags.cmx my_unix.cmx my_std.cmx discard_printf.cmx display.cmi
+exit_codes.cmo : exit_codes.cmi
+exit_codes.cmx : exit_codes.cmi
+fda.cmo : pathname.cmi options.cmi log.cmi hygiene.cmi fda.cmi
+fda.cmx : pathname.cmx options.cmx log.cmx hygiene.cmx fda.cmi
+findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi command.cmi findlib.cmi
+findlib.cmx : my_unix.cmx my_std.cmx lexers.cmi command.cmx findlib.cmi
+flags.cmo : tags.cmi param_tags.cmi command.cmi bool.cmi flags.cmi
+flags.cmx : tags.cmx param_tags.cmx command.cmx bool.cmx flags.cmi
+glob.cmo : my_std.cmi glob_lexer.cmi glob_ast.cmi bool.cmi glob.cmi
+glob.cmx : my_std.cmx glob_lexer.cmi glob_ast.cmx bool.cmx glob.cmi
+glob_ast.cmo : bool.cmi glob_ast.cmi
+glob_ast.cmx : bool.cmx glob_ast.cmi
+hooks.cmo : hooks.cmi
+hooks.cmx : hooks.cmi
+hygiene.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_std.cmi \
+ log.cmi hygiene.cmi
+hygiene.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_std.cmx \
+ log.cmx hygiene.cmi
+log.cmo : my_unix.cmi my_std.cmi display.cmi log.cmi
+log.cmx : my_unix.cmx my_std.cmx display.cmx log.cmi
+main.cmo : tools.cmi tags.cmi solver.cmi slurp.cmi shell.cmi rule.cmi \
+ resource.cmi report.cmi plugin.cmi pathname.cmi param_tags.cmi \
+ options.cmi ocaml_utils.cmi ocaml_specific.cmi ocaml_dependencies.cmi \
+ my_unix.cmi my_std.cmi log.cmi lexers.cmi hooks.cmi flags.cmi fda.cmi \
+ exit_codes.cmi digest_cache.cmi configuration.cmi command.cmi main.cmi
+main.cmx : tools.cmx tags.cmx solver.cmx slurp.cmx shell.cmx rule.cmx \
+ resource.cmx report.cmx plugin.cmx pathname.cmx param_tags.cmx \
+ options.cmx ocaml_utils.cmx ocaml_specific.cmx ocaml_dependencies.cmx \
+ my_unix.cmx my_std.cmx log.cmx lexers.cmi hooks.cmx flags.cmx fda.cmx \
+ exit_codes.cmx digest_cache.cmx configuration.cmx command.cmx main.cmi
+my_std.cmo : my_std.cmi
+my_std.cmx : my_std.cmi
+my_unix.cmo : my_std.cmi my_unix.cmi
+my_unix.cmx : my_std.cmx my_unix.cmi
+ocaml_arch.cmo : pathname.cmi my_std.cmi command.cmi ocaml_arch.cmi
+ocaml_arch.cmx : pathname.cmx my_std.cmx command.cmx ocaml_arch.cmi
+ocaml_compiler.cmo : tools.cmi tags.cmi rule.cmi resource.cmi pathname.cmi \
+ options.cmi ocaml_utils.cmi ocaml_dependencies.cmi ocaml_arch.cmi \
+ my_std.cmi log.cmi command.cmi ocaml_compiler.cmi
+ocaml_compiler.cmx : tools.cmx tags.cmx rule.cmx resource.cmx pathname.cmx \
+ options.cmx ocaml_utils.cmx ocaml_dependencies.cmx ocaml_arch.cmx \
+ my_std.cmx log.cmx command.cmx ocaml_compiler.cmi
+ocaml_dependencies.cmo : tools.cmi resource.cmi pathname.cmi ocaml_utils.cmi \
+ my_std.cmi log.cmi ocaml_dependencies.cmi
+ocaml_dependencies.cmx : tools.cmx resource.cmx pathname.cmx ocaml_utils.cmx \
+ my_std.cmx log.cmx ocaml_dependencies.cmi
+ocaml_specific.cmo : tools.cmi tags.cmi rule.cmi pathname.cmi options.cmi \
+ ocaml_utils.cmi ocaml_tools.cmi ocaml_compiler.cmi my_std.cmi log.cmi \
+ flags.cmi findlib.cmi configuration.cmi command.cmi ocaml_specific.cmi
+ocaml_specific.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \
+ ocaml_utils.cmx ocaml_tools.cmx ocaml_compiler.cmx my_std.cmx log.cmx \
+ flags.cmx findlib.cmx configuration.cmx command.cmx ocaml_specific.cmi
+ocaml_tools.cmo : tools.cmi tags.cmi rule.cmi pathname.cmi options.cmi \
+ ocaml_utils.cmi ocaml_compiler.cmi my_std.cmi flags.cmi command.cmi \
+ ocaml_tools.cmi
+ocaml_tools.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \
+ ocaml_utils.cmx ocaml_compiler.cmx my_std.cmx flags.cmx command.cmx \
+ ocaml_tools.cmi
+ocaml_utils.cmo : tools.cmi tags.cmi pathname.cmi param_tags.cmi options.cmi \
+ my_std.cmi log.cmi lexers.cmi flags.cmi command.cmi ocaml_utils.cmi
+ocaml_utils.cmx : tools.cmx tags.cmx pathname.cmx param_tags.cmx options.cmx \
+ my_std.cmx log.cmx lexers.cmi flags.cmx command.cmx ocaml_utils.cmi
+ocamlbuild.cmo : ocamlbuild_unix_plugin.cmi ocamlbuild.cmi
+ocamlbuild.cmx : ocamlbuild_unix_plugin.cmx ocamlbuild.cmi
+ocamlbuild_Myocamlbuild_config.cmo :
+ocamlbuild_Myocamlbuild_config.cmx :
+ocamlbuild_executor.cmo : ocamlbuild_executor.cmi
+ocamlbuild_executor.cmx : ocamlbuild_executor.cmi
+ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi
+ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi
+ocamlbuild_unix_plugin.cmo : ocamlbuild_executor.cmi my_unix.cmi my_std.cmi \
+ exit_codes.cmi ocamlbuild_unix_plugin.cmi
+ocamlbuild_unix_plugin.cmx : ocamlbuild_executor.cmx my_unix.cmx my_std.cmx \
+ exit_codes.cmx ocamlbuild_unix_plugin.cmi
+ocamlbuild_where.cmo : ocamlbuild_Myocamlbuild_config.cmo \
+ ocamlbuild_where.cmi
+ocamlbuild_where.cmx : ocamlbuild_Myocamlbuild_config.cmx \
+ ocamlbuild_where.cmi
+ocamlbuildlight.cmo : ocamlbuildlight.cmi
+ocamlbuildlight.cmx : ocamlbuildlight.cmi
+options.cmo : shell.cmi ocamlbuild_where.cmi \
+ ocamlbuild_Myocamlbuild_config.cmo my_std.cmi log.cmi lexers.cmi \
+ command.cmi options.cmi
+options.cmx : shell.cmx ocamlbuild_where.cmx \
+ ocamlbuild_Myocamlbuild_config.cmx my_std.cmx log.cmx lexers.cmi \
+ command.cmx options.cmi
+param_tags.cmo : my_std.cmi log.cmi lexers.cmi param_tags.cmi
+param_tags.cmx : my_std.cmx log.cmx lexers.cmi param_tags.cmi
+pathname.cmo : shell.cmi options.cmi my_unix.cmi my_std.cmi log.cmi glob.cmi \
+ pathname.cmi
+pathname.cmx : shell.cmx options.cmx my_unix.cmx my_std.cmx log.cmx glob.cmx \
+ pathname.cmi
+plugin.cmo : tools.cmi tags.cmi shell.cmi rule.cmi pathname.cmi options.cmi \
+ ocamlbuild_where.cmi my_unix.cmi my_std.cmi log.cmi command.cmi \
+ plugin.cmi
+plugin.cmx : tools.cmx tags.cmx shell.cmx rule.cmx pathname.cmx options.cmx \
+ ocamlbuild_where.cmx my_unix.cmx my_std.cmx log.cmx command.cmx \
+ plugin.cmi
+ppcache.cmo : shell.cmi pathname.cmi my_std.cmi log.cmi command.cmi \
+ ppcache.cmi
+ppcache.cmx : shell.cmx pathname.cmx my_std.cmx log.cmx command.cmx \
+ ppcache.cmi
+report.cmo : solver.cmi resource.cmi my_std.cmi log.cmi glob.cmi report.cmi
+report.cmx : solver.cmx resource.cmx my_std.cmx log.cmx glob.cmx report.cmi
+resource.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_unix.cmi \
+ my_std.cmi log.cmi lexers.cmi glob_ast.cmi glob.cmi digest_cache.cmi \
+ command.cmi resource.cmi
+resource.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_unix.cmx \
+ my_std.cmx log.cmx lexers.cmi glob_ast.cmx glob.cmx digest_cache.cmx \
+ command.cmx resource.cmi
+rule.cmo : tags.cmi shell.cmi resource.cmi pathname.cmi options.cmi \
+ my_std.cmi log.cmi digest_cache.cmi command.cmi rule.cmi
+rule.cmx : tags.cmx shell.cmx resource.cmx pathname.cmx options.cmx \
+ my_std.cmx log.cmx digest_cache.cmx command.cmx rule.cmi
+shell.cmo : tags.cmi my_unix.cmi my_std.cmi log.cmi shell.cmi
+shell.cmx : tags.cmx my_unix.cmx my_std.cmx log.cmx shell.cmi
+slurp.cmo : my_unix.cmi my_std.cmi slurp.cmi
+slurp.cmx : my_unix.cmx my_std.cmx slurp.cmi
+solver.cmo : rule.cmi resource.cmi pathname.cmi my_std.cmi log.cmi \
+ command.cmi solver.cmi
+solver.cmx : rule.cmx resource.cmx pathname.cmx my_std.cmx log.cmx \
+ command.cmx solver.cmi
+tags.cmo : tags.cmi
+tags.cmx : tags.cmi
+tools.cmo : tags.cmi rule.cmi pathname.cmi my_std.cmi log.cmi \
+ configuration.cmi tools.cmi
+tools.cmx : tags.cmx rule.cmx pathname.cmx my_std.cmx log.cmx \
+ configuration.cmx tools.cmi
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
.PHONY: all byte native profile debug ppcache doc
ifndef INSTALL_PREFIX
--- /dev/null
+#(***********************************************************************)
+#(* *)
+#(* ocamlbuild *)
+#(* *)
+#(* Wojciech Meyer *)
+#(* *)
+#(* Copyright 2012 Institut National de Recherche en Informatique et *)
+#(* en Automatique. All rights reserved. This file is distributed *)
+#(* under the terms of the Q Public License version 1.0. *)
+#(* *)
+#(***********************************************************************)
+
+# This file removes the dependency on ocamlbuild itself, thus removes need
+# for bootstrap. The base for this Makefile was ocamldoc Makefile.
+
+include ../config/Makefile
+
+# Various commands and dir
+##########################
+CAMLRUN = ../boot/ocamlrun
+OCAMLC = ../ocamlcomp.sh
+OCAMLOPT = ../ocamlcompopt.sh
+OCAMLDEP = $(CAMLRUN) ../tools/ocamldep
+OCAMLLEX = $(CAMLRUN) ../boot/ocamllex
+OCAMLLIB = $(LIBDIR)
+OCAMLBIN = $(BINDIR)
+
+# For installation
+##############
+MKDIR=mkdir -p
+CP=cp -f
+OCAMLBUILD=ocamlbuild
+OCAMLBUILD_OPT=$(OCAMLBUILD).opt
+OCAMLBUILD_LIBCMA=ocamlbuildlib.cma
+OCAMLBUILD_LIBCMI=ocamlbuildlib.cmi
+OCAMLBUILD_LIBCMXA=ocamlbuild.cmxa
+OCAMLBUILD_LIBA=ocamlbuild.$(A)
+INSTALL_LIBDIR=$(OCAMLLIB)/ocamlbuild
+INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom
+INSTALL_BINDIR=$(OCAMLBIN)
+INSTALL_MANODIR=$(MANDIR)/man3
+
+INSTALL_MLIS=
+INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
+
+# Compilation
+#############
+OCAMLSRCDIR=..
+INCLUDES_DEP=
+
+INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \
+ -I $(OCAMLSRCDIR)/otherlibs/str \
+ -I $(OCAMLSRCDIR)/otherlibs/dynlink \
+ -I $(OCAMLSRCDIR)/otherlibs/unix
+
+INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
+
+COMPFLAGS=$(INCLUDES) -warn-error A
+LINKFLAGS=$(INCLUDES)
+
+CMOFILES_PACK= \
+ ocamlbuild_Myocamlbuild_config.cmo \
+ discard_printf.cmo \
+ my_std.cmo \
+ bool.cmo \
+ glob_ast.cmo \
+ glob_lexer.cmo \
+ glob.cmo \
+ lexers.cmo \
+ my_unix.cmo \
+ tags.cmo \
+ display.cmo \
+ log.cmo \
+ param_tags.cmo \
+ shell.cmo \
+ slurp.cmo \
+ ocamlbuild_where.cmo \
+ command.cmo \
+ options.cmo \
+ pathname.cmo \
+ digest_cache.cmo \
+ resource.cmo \
+ rule.cmo \
+ flags.cmo \
+ solver.cmo \
+ report.cmo \
+ ocaml_arch.cmo \
+ hygiene.cmo \
+ configuration.cmo \
+ tools.cmo \
+ fda.cmo \
+ plugin.cmo \
+ ocaml_utils.cmo \
+ ocaml_dependencies.cmo \
+ ocaml_compiler.cmo \
+ ocaml_tools.cmo \
+ hooks.cmo \
+ findlib.cmo \
+ ocaml_specific.cmo \
+ exit_codes.cmo \
+ main.cmo
+
+BASE_CMOFILES= ocamlbuild_executor.cmo \
+ ocamlbuild_unix_plugin.cmo
+
+INSTALL_LIBFILES = $(BASE_CMOFILES) \
+ $(BASE_CMOFILES:.cmo=.cmi) \
+ $(OCAMLBUILD_LIBCMA) \
+ $(OCAMLBUILD).cmo \
+ $(OCAMLBUILD)_pack.cmi
+
+INSTALL_BINFILES = $(OCAMLBUILD)
+
+CMXFILES= $(CMOFILES:.cmo=.cmx)
+
+CMXFILES_PACK= $(CMOFILES_PACK:.cmo=.cmx)
+CMIFILES_PACK= $(CMOFILES_PACK:.cmo=.cmi) signatures.cmi
+
+EXECMOFILES_PACK= $(CMOFILES_PACK)
+EXECMXFILES_PACK= $(EXECMOFILES_PACK:.cmo=.cmx)
+EXECMIFILES_PACK= $(EXECMOFILES_PACK:.cmo=.cmi)
+
+LIBCMOFILES_PACK= $(CMOFILES_PACK)
+LIBCMXFILES_PACK= $(LIBCMOFILES_PACK:.cmo=.cmx)
+LIBCMIFILES_PACK= $(LIBCMOFILES_PACK:.cmo=.cmi)
+
+# Les cmo et cmx de la distrib OCAML
+OCAMLCMOFILES=
+OCAMLCMXFILES=$(OCAMLCMOFILES_PACK:.cmo=.cmx)
+
+all: exe lib
+opt: $(OCAMLBUILD).native
+exe: $(OCAMLBUILD)
+lib: $(OCAMLBUILD_LIBCMA)
+
+opt.opt: exeopt libopt
+exeopt: $(OCAMLBUILD_OPT)
+libopt: $(OCAMLBUILD_LIBCMXA) $(OCAMLBUILD_LIBCMI)
+
+debug:
+ $(MAKE) OCAMLPP=""
+
+$(OCAMLBUILD)_pack.cmo: $(CMOFILES_PACK) $(CMIFILES_PACK)
+ $(OCAMLC) -pack -o $@ $(LINKFLAGS) $(OCAMLCMOFILES_PACK) $(EXECMOFILES_PACK) signatures.mli
+
+$(OCAMLBUILD)_pack.cmx: $(EXECMXFILES_PACK)
+ $(OCAMLOPT) -pack -o $@ $(LINKFLAGS) $(OCAMLCMOFILES_PACK) $(EXECMXFILES_PACK)
+
+$(OCAMLBUILD): $(OCAMLBUILD)_pack.cmo $(CMOFILES) $(OCAMLBUILD).cmo $(BASE_CMOFILES)
+ $(OCAMLC) -o $@ unix.cma $(LINKFLAGS) $(OCAMLBUILD)_pack.cmo $(CMOFILES)
+
+$(OCAMLBUILD).native: $(OCAMLBUILD)_pack.cmx $(CMXFILES)
+ $(OCAMLOPT) -o $@ $(LINKFLAGS) $(CMXFILES)
+
+$(OCAMLBUILD_LIBCMA): $(LIBCMOFILES_PACK)
+ $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES_PACK)
+$(OCAMLBUILD_LIBCMXA): $(LIBCMXFILES)
+ $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES)
+
+# generic rules :
+#################
+
+.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs
+
+.ml.cmo:
+ $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
+
+.mli.cmi:
+ $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
+
+.ml.cmx:
+ $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
+
+.ml.cmxs:
+ $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $<
+
+.mll.ml:
+ $(OCAMLLEX) $<
+
+.mly.ml:
+ $(OCAMLYACC) -v $<
+
+.mly.mli:
+ $(OCAMLYACC) -v $<
+
+# Installation targets
+######################
+install: dummy
+ if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi
+ if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi
+ if test -d $(INSTALL_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi
+ $(CP) $(OCAMLBUILD) $(INSTALL_BINDIR)/$(OCAMLBUILD)$(EXE)
+ $(CP) $(INSTALL_LIBFILES) $(INSTALL_LIBDIR)
+ $(CP) $(INSTALL_BINFILES) $(INSTALL_BINDIR)
+
+installopt:
+ if test -f $(OCAMLBUILD_OPT) ; then $(MAKE) installopt_really ; fi
+
+installopt_really:
+ if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi
+ if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi
+ $(CP) ocamlbuild.hva $(OCAMLBUILD_LIBA) $(OCAMLBUILD_LIBCMXA) $(INSTALL_LIBDIR)
+ $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
+
+
+# backup, clean and depend :
+############################
+
+clean:: dummy
+ @rm -f *~ \#*\#
+ @rm -f $(OCAMLBUILD) $(OCAMLBUILD_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O)
+ @rm -f glob_lexer.ml lexers.ml
+
+depend::
+ $(OCAMLDEP) $(INCLUDES_DEP) *.mli *.mll *.mly *.ml > .depend
+
+dummy:
+
+include .depend
+
+# Additional rules
+glob_lexer.cmo: glob_lexer.cmi
+lexers.cmo: lexers.cmi
+
+glob_lexer.cmx: glob_lexer.cmi
+lexers.cmx: lexers.cmi
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
let paths =
try
parse_path (Lexing.from_string path_var)
- with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg))
+ with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos))
in
let norm_current_dir_name path =
if path = "" then Filename.current_dir_name else path
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
configs := config :: !configs;
Hashtbl.clear cache)
-let parse_string s =
- let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in
+let parse_lexbuf ?dir source lexbuf =
+ lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source };
+ let conf = Lexers.conf_lines dir lexbuf in
add_config conf
+let parse_string s = parse_lexbuf (Printf.sprintf "String %S" s) (Lexing.from_string s)
+
let parse_file ?dir file =
- try
- with_input_file file begin fun ic ->
- let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in
- add_config conf
- end
- with Lexers.Error msg -> raise (Lexers.Error (file ^ ": " ^ msg))
+ with_input_file file begin fun ic ->
+ parse_lexbuf ?dir (Printf.sprintf "File %S" file) (Lexing.from_channel ic)
+ end
let key_match = Glob.eval
let () = Hashtbl.replace cache s res in
res
-let has_tag tag = Tags.mem tag (tags_of_filename "")
+let global_tags () = tags_of_filename ""
+let has_tag tag = Tags.mem tag (global_tags ())
let tag_file file tags =
if tags <> [] then parse_string (Printf.sprintf "%S: %s" file (String.concat ", " tags));;
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(** [tag_any tag_list] Tag anything with all given tags. *)
val tag_any : Tags.elt list -> unit
+
+(** the tags that apply to any file *)
+val global_tags : unit -> Tags.t
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
match di.di_display_line with
| Classic ->
if pretend then
- (if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command)
+ begin
+ (* This should work, even on Windows *)
+ let command = Filename.basename command in
+ if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command
+ end
else
(if di.di_log_level >= 1 then Format.fprintf di.di_formatter "%s\n%!" command)
| Sophisticated ds ->
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(***********************************************************************)
+(* *)
+(* ocamlbuild *)
+(* *)
+(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let _ =
Printf.printf "Hello, %s ! My name is %s\n"
(if Array.length Sys.argv > 1 then Sys.argv.(1) else "stranger")
+(***********************************************************************)
+(* *)
+(* ocamlbuild *)
+(* *)
+(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
type how = Nicely | Badly;;
let greet how who =
+(***********************************************************************)
+(* *)
+(* ocamlbuild *)
+(* *)
+(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Greet
let _ =
+(***********************************************************************)
+(* *)
+(* ocamlbuild *)
+(* *)
+(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let _ =
let s = Num.num_of_string (Printf.sprintf "%.0f" (Unix.gettimeofday ())) in
let ps = Num.mult_num (Num.num_of_string "1000000000000") s in
#!/bin/sh
+#########################################################################
+# #
+# OCaml #
+# #
+# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2007 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
set -e
TARGET=epoch
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* TODO: Improve to differenciate whether ocamlfind cannot be
run or is not installed *)
error Cannot_run_ocamlfind
- | Lexers.Error s ->
+ | Lexers.Error (s,_) ->
error (Cannot_parse_query (name, s))
let split_nl s =
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
| QEPSILON
;;
- module IS = Set.Make(struct type t = int let compare = compare let print = Format.pp_print_int end);;
+ module IS = Set.Make(struct type t = int let compare (x:t) y = compare x y let print = Format.pp_print_int end);;
module ISM = Map.Make(struct type t = IS.t let compare = IS.compare let print = IS.print end);;
type machine = {
| QEPSILON -> epsilons := (q1,q2) :: !epsilons; q1
| QCLASS cl -> transitions := (q1,cl,q2) :: !transitions; q1
in
- (* Construit les transitions correspondant au motif donné et arrivant
- * sur l'état qf. Retourne l'état d'origine. *)
+ (* Construit les transitions correspondant au motif donne et arrivant
+ * sur l'etat qf. Retourne l'etat d'origine. *)
let rec loop qf = function
| Epsilon -> qf
| Word u ->
| Word v ->
String.length v = n &&
begin
- let rec check j = j = n or (v.[j] = u.[i + j] && check (j + 1))
+ let rec check j = j = n || (v.[j] = u.[i + j] && check (j + 1))
in
check 0
end
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* Original author: Nicolas Pouillard *)
-exception Error of string
+exception Error of (string * Lexing.position)
type conf_values =
{ plus_tags : string list;
(* Same one, for Windows (PATH is ;-separated) *)
val parse_environment_path_w : Lexing.lexbuf -> string list
-val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf
+val conf_lines : string option -> Lexing.lexbuf -> conf
val path_scheme : bool -> Lexing.lexbuf ->
[ `Word of string
| `Var of (string * Glob.globber)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* Original author: Nicolas Pouillard *)
{
-exception Error of string
+exception Error of (string * Lexing.position)
+
+let error lexbuf fmt = Printf.ksprintf (fun s -> raise (Error (s,Lexing.lexeme_start_p lexbuf))) fmt
+
open Glob_ast
type conf_values =
rule ocamldep_output = parse
| ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf }
| eof { [] }
- | _ { raise (Error "Expecting colon followed by space-separated module name list") }
+ | _ { error lexbuf "Expecting colon followed by space-separated module name list" }
and space_sep_strings_nl = parse
| space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf }
- | space* newline { [] }
- | _ { raise (Error "Expecting space-separated strings terminated with newline") }
+ | space* newline { Lexing.new_line lexbuf; [] }
+ | _ { error lexbuf "Expecting space-separated strings terminated with newline" }
and space_sep_strings = parse
| space* (not_blank+ as word) { word :: space_sep_strings lexbuf }
| space* newline? eof { [] }
- | _ { raise (Error "Expecting space-separated strings") }
+ | _ { error lexbuf "Expecting space-separated strings" }
and blank_sep_strings = parse
| blank* '#' not_newline* newline { blank_sep_strings lexbuf }
| blank* '#' not_newline* eof { [] }
| blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf }
| blank* eof { [] }
- | _ { raise (Error "Expecting blank-separated strings") }
+ | _ { error lexbuf "Expecting blank-separated strings" }
and comma_sep_strings = parse
| space* (not_space_nor_comma+ as word) space* eof { [word] }
| space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting comma-separated strings (1)") }
+ | _ { error lexbuf "Expecting comma-separated strings (1)" }
and comma_sep_strings_aux = parse
| space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting comma-separated strings (2)") }
+ | _ { error lexbuf "Expecting comma-separated strings (2)" }
and comma_or_blank_sep_strings = parse
| space* (not_space_nor_comma+ as word) space* eof { [word] }
| space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") }
+ | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" }
and comma_or_blank_sep_strings_aux = parse
| space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
| space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") }
+ | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" }
and parse_environment_path_w = parse
| ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
and parse_environment_path_aux_w = parse
| ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
| eof { [] }
- | _ { raise (Error "Impossible: expecting colon-separated strings") }
+ | _ { error lexbuf "Impossible: expecting colon-separated strings" }
and parse_environment_path = parse
| ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
and parse_environment_path_aux = parse
| ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
| eof { [] }
- | _ { raise (Error "Impossible: expecting colon-separated strings") }
+ | _ { error lexbuf "Impossible: expecting colon-separated strings" }
-and conf_lines dir pos err = parse
- | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf }
+and conf_lines dir = parse
+ | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf }
| space* '#' not_newline* eof { [] }
- | space* newline { conf_lines dir (pos + 1) err lexbuf }
+ | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf }
| space* eof { [] }
| space* (not_newline_nor_colon+ as k) space* ':' space*
{
- let bexpr = Glob.parse ?dir k in
- let v1 = conf_value pos err empty lexbuf in
- let v2 = conf_values pos err v1 lexbuf in
- let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest
+ let bexpr =
+ try Glob.parse ?dir k
+ with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn)
+ in
+ let v1 = conf_value empty lexbuf in
+ let v2 = conf_values v1 lexbuf in
+ Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *)
+ let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest
}
- | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) }
+ | _ { error lexbuf "Invalid line syntax" }
-and conf_value pos err x = parse
+and conf_value x = parse
| '-' (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } }
| '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } }
- | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) }
+ | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" }
-and conf_values pos err x = parse
- | space_or_esc_nl* ',' space_or_esc_nl* { conf_values pos err (conf_value pos err x lexbuf) lexbuf }
+and conf_values x = parse
+ | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf }
| (newline | eof) { x }
- | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) }
+ | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" }
and path_scheme patt_allowed = parse
| ([^ '%' ]+ as prefix)
{ if patt_allowed then
let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in
`Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf
- else raise (Error(
- Printf.sprintf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)"
- var patt)) }
+ else
+ error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt }
| '%'
{ `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf }
| eof
{ [] }
- | _ { raise (Error("Bad pathanme scheme")) }
+ | _ { error lexbuf "Bad pathanme scheme" }
and unescape = parse
| '\\' (['(' ')'] as c) { c :: unescape lexbuf }
"linkopts:" space* (not_newline* as lo) newline+
"location:" space* (not_newline* as l) newline+
{ n, d, v, a, lo, l }
- | _ { raise (Error "Bad ocamlfind query") }
+ | _ { error lexbuf "Bad ocamlfind query" }
and trim_blanks = parse
| blank* (not_blank* as word) blank* { word }
- | _ { raise (Error "Bad input for trim_blanks") }
+ | _ { error lexbuf "Bad input for trim_blanks" }
and tag_gen = parse
| (normal+ as name) ('(' ([^')']* as param) ')')? { name, param }
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
Options.init ();
if !Options.must_clean then clean ();
Hooks.call_hook Hooks.After_options;
- Plugin.execute_plugin_if_needed ();
-
- if !Options.targets = []
- && !Options.show_tags = []
- && not !Options.show_documentation
- then raise Exit_silently;
+ let options_wd = Sys.getcwd () in
+ let first_run_for_plugin =
+ (* If we are in the first run before launching the plugin, we
+ should skip the user-visible operations (hygiene) that may need
+ information from the plugin to run as the user expects it.
+
+ Note that we don't need to disable the [Hooks] call as they are
+ no-ops anyway, before any plugin has registered hooks. *)
+ Plugin.we_need_a_plugin () && not !Options.just_plugin in
let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in
(fun pkg -> Configuration.tag_any [Param_tags.make "package" pkg])
!Options.ocaml_pkgs;
+ begin match !Options.ocaml_syntax with
+ | Some syntax -> Configuration.tag_any [Param_tags.make "syntax" syntax]
+ | None -> () end;
+
let newpwd = Sys.getcwd () in
Sys.chdir Pathname.pwd;
let entry_include_dirs = ref [] in
(List.mem name ["_oasis"] || (String.length name > 0 && name.[0] <> '_'))
&& (name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs))
&& begin
- if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then
+ not (path_name <> Filename.current_dir_name && Pathname.is_directory path_name)
+ || begin
let tags = tags_of_pathname path_name in
- if Tags.mem "include" tags
- || List.mem path_name !Options.include_dirs then
+ (if Tags.mem "include" tags
+ || List.mem path_name !Options.include_dirs then
(entry_include_dirs := path_name :: !entry_include_dirs; true)
else
Tags.mem "traverse" tags
|| List.exists (Pathname.is_prefix path_name) !Options.include_dirs
- || List.exists (Pathname.is_prefix path_name) target_dirs
- else true
+ || List.exists (Pathname.is_prefix path_name) target_dirs)
+ && ((* beware: !Options.build_dir is an absolute directory *)
+ Pathname.normalize !Options.build_dir
+ <> Pathname.normalize (Pathname.pwd/path_name))
+ end
end
end
(Slurp.slurp Filename.current_dir_name)
let tags = tags_of_pathname (path/name) in
not (Tags.mem "not_hygienic" tags) && not (Tags.mem "precious" tags)
end entry in
- if !Options.hygiene then
+ if !Options.hygiene && not first_run_for_plugin then
Fda.inspect hygiene_entry
else
Slurp.force hygiene_entry;
Ocaml_specific.init ();
Hooks.call_hook Hooks.After_rules;
+ Sys.chdir options_wd;
+ Plugin.execute_plugin_if_needed ();
+
+ (* [Param_tags.init ()] is called *after* the plugin is executed, as
+ some of the parametrized tags present in the _tags files parsed
+ will be declared by the plugin, and would therefore result in
+ "tag X does not expect a parameter" warnings if initialized
+ before. Note that [Plugin.rebuild_plugin_if_needed] is careful to
+ partially initialize the tags that it uses for plugin compilation. *)
Param_tags.init ();
Sys.chdir newpwd;
| Ocaml_utils.Ocamldep_error msg ->
Log.eprintf "Ocamldep error: %s" msg;
exit rc_ocamldep_error
- | Lexers.Error msg ->
- Log.eprintf "Lexical analysis error: %s" msg;
+ | Lexers.Error (msg,pos) ->
+ let module L = Lexing in
+ Log.eprintf "%s, line %d, column %d: Lexing error: %s." pos.L.pos_fname pos.L.pos_lnum (pos.L.pos_cnum - pos.L.pos_bol) msg;
exit rc_lexing_error
| Arg.Bad msg ->
Log.eprintf "%s" msg;
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
.\"***********************************************************************)
+.\"* *)
.\"* ocamlbuild *)
.\"* *)
.\"* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
module type S = sig
include Set.S
- val find : (elt -> bool) -> t -> elt
+ val find_elt : (elt -> bool) -> t -> elt
val map : (elt -> elt) -> t -> t
val of_list : elt list -> t
val print : formatter -> t -> unit
module Make (M : OrderedTypePrintable) : S with type elt = M.t = struct
include Set.Make(M)
exception Found of elt
- let find p set =
+ let find_elt p set =
try
iter begin fun elt ->
if p elt then raise (Found elt)
and n = String.length v
in
m <= n &&
- let rec loop i = i = m or u.[i] = v.[i] && loop (i + 1) in
+ let rec loop i = i = m || u.[i] = v.[i] && loop (i + 1) in
loop 0
(* ***)
and n = String.length v
in
n <= m &&
- let rec loop i = i = n or u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in
+ let rec loop i = i = n || u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in
loop 0
(* ***)
with Not_found ->
let res = f x in
(Hashtbl.add cache x res; res)
+
+let memo2 f =
+ let cache = Hashtbl.create 103 in
+ fun x y ->
+ try Hashtbl.find cache (x,y)
+ with Not_found ->
+ let res = f x y in
+ (Hashtbl.add cache (x,y) res; res)
+
+let memo3 f =
+ let cache = Hashtbl.create 103 in
+ fun x y z ->
+ try Hashtbl.find cache (x,y,z)
+ with Not_found ->
+ let res = f x y z in
+ (Hashtbl.add cache (x,y,z) res; res)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(if Pathname.exists (ml-.-"depends") then path_dependencies_of ml else [])
(if Pathname.exists (mli-.-"depends") then path_dependencies_of mli else [])
in
+ let modules =
+ if (modules = []) && (Pathname.exists (ml^"pack")) then
+ List.map (fun s -> (`mandatory, s)) (string_list_of_file (ml^"pack"))
+ else
+ modules
+ in
if modules <> [] && not (Hashtbl.mem cache_prepare_link key) then
let () = Hashtbl.add cache_prepare_link key true in
let modules' = List.map (fun (_, x) -> expand_module include_dirs x extensions) modules in
let byte_link = byte_link_gen ocamlc_link_prog
(fun tags -> tags++"ocaml"++"link"++"byte"++"program")
+let byte_output_obj = byte_link_gen ocamlc_link_prog
+ (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj")
+
let byte_library_link = byte_link_gen byte_lib_linker byte_lib_linker_tags
let byte_debug_link_gen =
let native_link x = native_link_gen ocamlopt_link_prog
(fun tags -> tags++"ocaml"++"link"++"native"++"program") x
+let native_output_obj x = native_link_gen ocamlopt_link_prog
+ (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x
+
let native_library_link x =
native_link_gen native_lib_linker native_lib_linker_tags x
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(Tags.t -> Tags.t) ->
string -> string -> Rule.action
val byte_link : string -> string -> Rule.action
+val byte_output_obj : string -> string -> Rule.action
val byte_library_link : string -> string -> Rule.action
val byte_debug_link : string -> string -> Rule.action
val byte_debug_library_link : string -> string -> Rule.action
val native_link : string -> string -> Rule.action
+val native_output_obj : string -> string -> Rule.action
val native_library_link : string -> string -> Rule.action
val native_shared_library_link : ?tags:(string list) -> string -> string -> Rule.action
val native_profile_link : string -> string -> Rule.action
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
~dep:"%.cmo"
(Ocaml_compiler.byte_link "%.cmo" "%.byte");;
+rule "ocaml: cmo* -> byte.o"
+ ~tags:["ocaml"; "byte"; "link"; "output_obj" ]
+ ~prod:"%.byte.o"
+ ~dep:"%.cmo"
+ (Ocaml_compiler.byte_output_obj "%.cmo" "%.byte.o");;
+
+rule "ocaml: cmo* -> byte.c"
+ ~tags:["ocaml"; "byte"; "link"; "output_obj" ]
+ ~prod:"%.byte.c"
+ ~dep:"%.cmo"
+ (Ocaml_compiler.byte_output_obj "%.cmo" "%.byte.c");;
+
rule "ocaml: p.cmx* & p.o* -> p.native"
~tags:["ocaml"; "native"; "profile"; "program"]
~prod:"%.p.native"
~deps:["%.cmx"; x_o]
(Ocaml_compiler.native_link "%.cmx" "%.native");;
+rule "ocaml: cmx* & o* -> native.o"
+ ~tags:["ocaml"; "native"; "output_obj" ]
+ ~prod:"%.native.o"
+ ~deps:["%.cmx"; x_o]
+ (Ocaml_compiler.native_output_obj "%.cmx" "%.native.o");;
+
rule "ocaml: mllib & d.cmo* -> d.cma"
~tags:["ocaml"; "byte"; "debug"; "library"]
~prod:"%.d.cma"
(Ocaml_compiler.byte_library_link "%.cmo" "%.cma");;
rule "ocaml C stubs: clib & (o|obj)* -> (a|lib) & (so|dll)"
- ~prods:["%(path:<**/>)lib%(libname:<*> and not <*.*>)"-.-ext_lib;
- "%(path:<**/>)dll%(libname:<*> and not <*.*>)"-.-ext_dll]
+ ~prods:(["%(path:<**/>)lib%(libname:<*> and not <*.*>)"-.-ext_lib] @
+ if Ocamlbuild_Myocamlbuild_config.supports_shared_libraries then
+ ["%(path:<**/>)dll%(libname:<*> and not <*.*>)"-.-ext_dll]
+ else
+ [])
~dep:"%(path)lib%(libname).clib"
(C_tools.link_C_library "%(path)lib%(libname).clib" ("%(path)lib%(libname)"-.-ext_lib) "%(path)%(libname)");;
flag ["ocaml"; "pp"; camlp4] (A camlp4)
end camlp4s;;
-camlp4_flags ["camlp4o"; "camlp4r"; "camlp4of"; "camlp4rf"; "camlp4orf"; "camlp4oof"];;
+let p4_series = ["camlp4o"; "camlp4r"; "camlp4of"; "camlp4rf"; "camlp4orf"; "camlp4oof"];;
+let p4_opt_series = List.map (fun f -> f ^ ".opt") p4_series;;
+
+camlp4_flags p4_series;;
+camlp4_flags p4_opt_series;;
let camlp4_flags' camlp4s =
List.iter begin fun (camlp4, flags) ->
flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");;
flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");;
flag ["ocaml"; "annot"; "compile"] (A "-annot");;
+flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot");;
+flag ["ocaml"; "short_paths"; "compile"] (A "-short-paths");;
+flag ["ocaml"; "short_paths"; "infer_interface"] (A "-short-paths");;
flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");;
flag ["ocaml"; "rectypes"; "infer_interface"] (A "-rectypes");;
flag ["ocaml"; "rectypes"; "doc"] (A "-rectypes");;
+flag ["ocaml"; "rectypes"; "pack"] (A "-rectypes");;
+flag ["ocaml"; "principal"; "compile"] (A "-principal");;
+flag ["ocaml"; "principal"; "infer_interface"] (A "-principal");;
flag ["ocaml"; "linkall"; "link"] (A "-linkall");;
flag ["ocaml"; "link"; "profile"; "native"] (A "-p");;
flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");;
(* threads, with or without findlib *)
flag ["ocaml"; "compile"; "thread"] (A "-thread");;
+flag ["ocaml"; "link"; "thread"] (A "-thread");;
if not !Options.use_ocamlfind then begin
flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]);
- flag ["ocaml"; "link"; "thread"; "native"; "program"] (S[A "threads.cmxa"; A "-thread"]);
- flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"]);
- flag ["ocaml"; "link"; "thread"; "native"; "toplevel"] (S[A "threads.cmxa"; A "-thread"]);
- flag ["ocaml"; "link"; "thread"; "byte"; "toplevel"] (S[A "threads.cma"; A "-thread"])
-end else begin
- flag ["ocaml"; "link"; "thread"; "program"] (A "-thread")
+ flag ["ocaml"; "link"; "thread"; "native"; "program"] (A "threads.cmxa");
+ flag ["ocaml"; "link"; "thread"; "byte"; "program"] (A "threads.cma");
+ flag ["ocaml"; "link"; "thread"; "native"; "toplevel"] (A "threads.cmxa");
+ flag ["ocaml"; "link"; "thread"; "byte"; "toplevel"] (A "threads.cma");
end;;
flag ["ocaml"; "compile"; "nopervasives"] (A"-nopervasives");;
flag ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.lowercase c)]
(S[A"-warn-error"; A (sprintf "%c" (Char.lowercase c))]);;
-List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'L'; 'M'; 'P'; 'R'; 'S'; 'U'; 'V'; 'Y'; 'Z'; 'X'];;
+List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'K'; 'L'; 'M'; 'P'; 'R'; 'S'; 'U'; 'V'; 'X'; 'Y'; 'Z'];;
+
+flag ["ocaml"; "compile"; "strict-sequence"] (A "-strict-sequence");;
+flag ["ocaml"; "compile"; "strict_sequence"] (A "-strict-sequence");;
flag ["ocaml"; "doc"; "docdir"; "extension:html"] (A"-html");;
flag ["ocaml"; "doc"; "docdir"; "manpage"] (A"-man");;
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
let menhir mly env build =
let mly = env mly in
let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in
+ let tags = tags_of_pathname mly in
+ let ocamlc_tags = tags++"ocaml"++"byte"++"compile" in
+ let menhir_tags = tags++"ocaml"++"parser"++"menhir" in
Ocaml_compiler.prepare_compile build mly;
Cmd(S[menhir;
- A"--ocamlc"; Quote(S[!Options.ocamlc; ocaml_include_flags mly]);
- T(tags_of_pathname mly++"ocaml"++"parser"++"menhir");
- A"--infer"; Px mly])
+ A"--ocamlc"; Quote(S[!Options.ocamlc; T ocamlc_tags; ocaml_include_flags mly]);
+ T menhir_tags; A"--infer"; Px mly])
let ocamldoc_c tags arg odoc =
let tags = tags++"ocaml" in
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
end
else if ignore_stdlib x then `just_try else `mandatory
-let expand_module include_dirs module_name exts =
- let dirname = Pathname.dirname module_name in
- let basename = Pathname.basename module_name in
- let module_name_cap = dirname/(String.capitalize basename) in
- let module_name_uncap = dirname/(String.uncapitalize basename) in
- List.fold_right begin fun include_dir ->
- List.fold_right begin fun ext acc ->
- include_dir/(module_name_uncap-.-ext) ::
- include_dir/(module_name_cap-.-ext) :: acc
- end exts
- end include_dirs []
+let expand_module =
+ memo3 (fun include_dirs module_name exts ->
+ let dirname = Pathname.dirname module_name in
+ let basename = Pathname.basename module_name in
+ let module_name_cap = dirname/(String.capitalize basename) in
+ let module_name_uncap = dirname/(String.uncapitalize basename) in
+ List.fold_right begin fun include_dir ->
+ List.fold_right begin fun ext acc ->
+ include_dir/(module_name_uncap-.-ext) ::
+ include_dir/(module_name_cap-.-ext) :: acc
+ end exts
+ end include_dirs [])
let string_list_of_file file =
with_input_file file begin fun ic ->
with_input_file depends begin fun ic ->
let ocamldep_output =
try Lexers.ocamldep_output (Lexing.from_channel ic)
- with Lexers.Error msg -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in
+ with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in
let deps =
List.fold_right begin fun (path, deps) acc ->
let module_name' = module_name_of_pathname path in
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
Log
My_unix
My_std
-Std_signatures
Signatures
Shell
Display
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
let catch_errors = ref true
let use_ocamlfind = ref false
-let mk_virtual_solvers =
+(* Currently only ocamlfind and menhir is defined as no-core tool,
+ perhaps later we need something better *)
+let is_core_tool = function "ocamlfind" | "menhir" -> false | _ -> true
+
+let find_tool cmd =
let dir = Ocamlbuild_where.bindir in
+ let core_tool = is_core_tool cmd in
+ let opt = cmd ^ ".opt" in
+ let search_in_path = memo Command.search_in_path in
+ if sys_file_exists !dir then
+ let long = filename_concat !dir cmd in
+ let long_opt = long ^ ".opt" in
+ (* This defines how the command will be found *)
+ let choices =
+ [(fun () -> if file_or_exe_exists long_opt then Some long_opt else None);
+ (fun () -> if file_or_exe_exists long then Some long else None)] in
+ (* For non core tool the preference is too look at PATH first *)
+ let choices' =
+ [fun () ->
+ try let _ = search_in_path opt in Some opt
+ with Not_found -> Some cmd]
+ in
+ let choices = if core_tool then choices @ choices' else choices' @ choices in
+ try
+ match (List.find (fun choice -> not (choice () = None)) choices) () with
+ Some cmd -> cmd
+ | None -> raise Not_found
+ with Not_found -> failwith (Printf.sprintf "Can't find tool: %s" cmd)
+ else
+ try let _ = search_in_path opt in opt
+ with Not_found -> cmd
+
+let mk_virtual_solvers =
List.iter begin fun cmd ->
- let opt = cmd ^ ".opt" in
- let a_opt = A opt in
- let a_cmd = A cmd in
- let search_in_path = memo Command.search_in_path in
let solver () =
- if sys_file_exists !dir then
- let long = filename_concat !dir cmd in
- let long_opt = long ^ ".opt" in
- if file_or_exe_exists long_opt then A long_opt
- else if file_or_exe_exists long then A long
- else try let _ = search_in_path opt in a_opt
- with Not_found -> a_cmd
- else
- try let _ = search_in_path opt in a_opt
- with Not_found -> a_cmd
+ A (find_tool cmd)
in Command.setup_virtual_command_solver (String.uppercase cmd) solver
end
let ocaml_libs_internal = ref []
let ocaml_mods_internal = ref []
let ocaml_pkgs_internal = ref []
+let ocaml_syntax = ref None
let ocaml_lflags_internal = ref []
let ocaml_cflags_internal = ref []
let ocaml_docflags_internal = ref []
let tags_internal = ref [["quiet"]]
let tag_lines_internal = ref []
let show_tags_internal = ref []
+let plugin_tags_internal = ref []
let log_file_internal = ref "_log"
let my_include_dirs = ref [[Filename.current_dir_name]]
"-vnum", Unit (fun () -> print_endline Sys.ocaml_version; raise Exit_OK),
" Display the version number";
"-quiet", Unit (fun () -> Log.level := 0), " Make as quiet as possible";
- "-verbose", Int (fun i -> Log.level := i + 2), "<level> Set the verbosity level";
+ "-verbose", Int (fun i -> Log.classic_display := true; Log.level := i + 2), "<level> Set the verbosity level";
"-documentation", Set show_documentation, " Show rules and flags";
"-log", Set_string log_file_internal, "<file> Set log file";
"-no-log", Unit (fun () -> log_file_internal := ""), " No log file";
"-pkg", String (add_to' ocaml_pkgs_internal), "<package> Link to this ocaml findlib package";
"-pkgs", String (add_to ocaml_pkgs_internal), "<package,...> (idem)";
"-package", String (add_to' ocaml_pkgs_internal), "<package> (idem)";
+ "-syntax", String (fun syntax -> ocaml_syntax := Some syntax), "<syntax> Specify syntax using ocamlfind";
"-lflag", String (add_to' ocaml_lflags_internal), "<flag> Add to ocamlc link flags";
"-lflags", String (add_to ocaml_lflags_internal), "<flag,...> (idem)";
"-cflag", String (add_to' ocaml_cflags_internal), "<flag> Add to ocamlc compile flags";
"-pp", String (add_to ocaml_ppflags_internal), "<flag,...> (idem)";
"-tag", String (add_to' tags_internal), "<tag> Add to default tags";
"-tags", String (add_to tags_internal), "<tag,...> (idem)";
+ "-plugin-tag", String (add_to' plugin_tags_internal), "<tag> Use this tag when compiling the myocamlbuild.ml plugin";
+ "-plugin-tags", String (add_to plugin_tags_internal), "<tag,...> (idem)";
"-tag-line", String (add_to' tag_lines_internal), "<tag> Use this line of tags (as in _tags)";
"-show-tags", String (add_to' show_tags_internal), "<path> Show tags that applies on that pathname";
"-install-lib-dir", Set_string Ocamlbuild_where.libdir, "<path> Set the install library directory";
"-install-bin-dir", Set_string Ocamlbuild_where.bindir, "<path> Set the install binary directory";
"-where", Unit (fun () -> print_endline !Ocamlbuild_where.libdir; raise Exit_OK), " Display the install library directory";
-
+ "-which", String (fun cmd -> print_endline (find_tool cmd); raise Exit_OK), "<command> Display path to the tool command";
"-ocamlc", set_cmd ocamlc, "<command> Set the OCaml bytecode compiler";
"-ocamlopt", set_cmd ocamlopt, "<command> Set the OCaml native compiler";
"-ocamldep", set_cmd ocamldep, "<command> Set the OCaml dependency tool";
let tags = ref []
let tag_lines = ref []
let show_tags = ref []
+let plugin_tags = ref []
let init () =
let anon_fun = add_to' targets_internal in
reorder tag_lines tag_lines_internal;
reorder ignore_list ignore_list_internal;
reorder show_tags show_tags_internal;
+ reorder plugin_tags plugin_tags_internal;
let check_dir dir =
if Filename.is_implicit dir then
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
include Signatures.OPTIONS with type command_spec = Command.spec
+(* this option is not in Signatures.OPTIONS yet because adding tags to
+ the compilation of the plugin is a recent feature that may still be
+ subject to change, so the interface may not be stable; besides,
+ there is obviously little to gain from tweaking that option from
+ inside the plugin itself... *)
+val plugin_tags : string list ref
+
val entry : bool Slurp.entry option ref
val init : unit -> unit
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
let declare name action =
Hashtbl.add declared_tags name (only_once action)
-let acknowledge tag =
- let tag = Lexers.tag_gen (Lexing.from_string tag) in
- acknowledged_tags := tag :: !acknowledged_tags
+let parse tag = Lexers.tag_gen (Lexing.from_string tag)
+let acknowledge tag =
+ acknowledged_tags := parse tag :: !acknowledged_tags
-let really_acknowledge (name, param) =
+let really_acknowledge ?(quiet=false) (name, param) =
match param with
| None ->
- if Hashtbl.mem declared_tags name then
+ if Hashtbl.mem declared_tags name && not quiet then
Log.eprintf "Warning: tag %S expects a parameter" name
| Some param ->
let actions = List.rev (Hashtbl.find_all declared_tags name) in
- if actions = [] then
- Log.eprintf "Warning: tag %S does not expect a parameter, but is used with parameter %S" name param;
+ if actions = [] && not quiet then
+ Log.eprintf "Warning: tag %S does not expect a parameter, \
+ but is used with parameter %S" name param;
List.iter (fun f -> f param) actions
+let partial_init ?quiet tags =
+ Tags.iter (fun tag -> really_acknowledge ?quiet (parse tag)) tags
+
let init () =
List.iter really_acknowledge (My_std.List.ordered_unique !acknowledged_tags)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
val init: unit -> unit
(** Initialize parameterized tags.
+
+This will make effective all instantiations [foo(bar)] such that the
+parametrized tag [foo] has been [declare]d and [foo(bar)] has been
+[acknowledge]d after the last [init] call. *)
+
+val partial_init: ?quiet:bool -> Tags.t -> unit
+(** Initialize a list of tags
-Call this function once all tags have been [declare]d and [acknowledge]d.
-If you [declare] or [acknowledge] a tag after having called [init], this will
-have no effect. [init] should only be called once. *)
+This will make effective the instances [foo(bar)] appearing
+in the given tag list, instead of those that have been
+[acknowledged] previously. This is for system use only. *)
val make: Tags.elt -> string -> Tags.elt
(** Make a parameterized tag instance.
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
let concat = filename_concat
-let compare = compare
+let compare (x:t) y = compare x y
let print = pp_print_string
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
open Command
;;
-module Make(U:sig end) =
- struct
- let plugin = "myocamlbuild"
- let plugin_file = plugin^".ml"
- let plugin_config_file = plugin^"_config.ml"
- let plugin_config_file_interface = plugin^"_config.mli"
- let we_have_a_config_file = sys_file_exists plugin_config_file
- let we_need_a_plugin = !Options.plugin && sys_file_exists plugin_file
- let we_have_a_plugin = sys_file_exists ((!Options.build_dir/plugin)^(!Options.exe))
- let we_have_a_config_file_interface = sys_file_exists plugin_config_file_interface
+let plugin = "myocamlbuild"
+let plugin_file = plugin^".ml"
+let plugin_config_file = plugin^"_config.ml"
+let plugin_config_file_interface = plugin^"_config.mli"
+let we_need_a_plugin () = !Options.plugin && sys_file_exists plugin_file
+let we_have_a_plugin () = sys_file_exists ((!Options.build_dir/plugin)^(!Options.exe))
+let we_have_a_config_file () = sys_file_exists plugin_config_file
+let we_have_a_config_file_interface () = sys_file_exists plugin_config_file_interface
+module Make(U:sig end) =
+ struct
+ let we_need_a_plugin = we_need_a_plugin ()
+ let we_have_a_plugin = we_have_a_plugin ()
+ let we_have_a_config_file = we_have_a_config_file ()
+ let we_have_a_config_file_interface = we_have_a_config_file_interface ()
let up_to_date_or_copy fn =
let fn' = !Options.build_dir/fn in
Pathname.exists fn &&
end
end
- let profiling = Tags.mem "profile" (tags_of_pathname plugin_file)
-
- let debugging = Tags.mem "debug" (tags_of_pathname plugin_file)
-
let rebuild_plugin_if_needed () =
let a = up_to_date_or_copy plugin_file in
- let b = (not we_have_a_config_file) or up_to_date_or_copy plugin_config_file in
- let c = (not we_have_a_config_file_interface) or up_to_date_or_copy plugin_config_file_interface in
+ let b = (not we_have_a_config_file) || up_to_date_or_copy plugin_config_file in
+ let c = (not we_have_a_config_file_interface) || up_to_date_or_copy plugin_config_file_interface in
if a && b && c && we_have_a_plugin then
() (* Up to date *)
(* FIXME: remove ocamlbuild_config.ml in _build/ if removed in parent *)
S[P plugin_config_file_interface; P plugin_config_file]
else P plugin_config_file
else N in
- let cma, cmo, more_options, compiler =
+
+ let cma, cmo, compiler, byte_or_native =
if !Options.native_plugin then
- "cmxa", "cmx", (if profiling then A"-p" else N), !Options.ocamlopt
+ "cmxa", "cmx", !Options.ocamlopt, "native"
else
- "cma", "cmo", (if debugging then A"-g" else N), !Options.ocamlc
+ "cma", "cmo", !Options.ocamlc, "byte"
in
- let ocamlbuildlib, ocamlbuild, libs =
- if (not !Options.native_plugin) && !*My_unix.is_degraded then
- "ocamlbuildlightlib", "ocamlbuildlight", N
- else
- "ocamlbuildlib", "ocamlbuild", A("unix"-.-cma)
+
+
+ let (unix_spec, ocamlbuild_lib_spec, ocamlbuild_module_spec) =
+
+ let use_light_mode =
+ not !Options.native_plugin && !*My_unix.is_degraded in
+ let use_ocamlfind_pkgs =
+ !Options.use_ocamlfind && !Options.plugin_tags <> [] in
+ (* The plugin has the following dependencies that must be
+ included during compilation:
+
+ - unix.cmxa, if it is available
+ - ocamlbuildlib.cm{a,xa}, the library part of ocamlbuild
+ - ocamlbuild.cm{o,x}, the module that performs the
+ initialization work of the ocamlbuild executable, using
+ modules of ocamlbuildlib.cmxa
+
+ We pass all this stuff to the compilation command for the
+ plugin, with two independent important details to handle:
+
+ (1) ocamlbuild is designed to still work in environments
+ where Unix is not available for some reason; in this
+ case, we should not link unix, and use the
+ "ocamlbuildlight.cmo" initialization module, which runs
+ a "light" version of ocamlbuild without unix. There is
+ also an ocamlbuildlightlib.cma archive to be used in that
+ case.
+
+ The boolean variable [use_light_mode] tells us whether we
+ are in this unix-deprived scenario.
+
+ (2) there are risks of compilation error due to
+ double-linking of native modules when the user passes its
+ own tags to the plugin compilation process (as was added
+ to support modular construction of
+ ocamlbuild plugins). Indeed, if we hard-code linking to
+ unix.cmxa in all cases, and the user
+ enables -use-ocamlfind and
+ passes -plugin-tag "package(unix)" (or package(foo) for
+ any foo which depends on unix), the command-line finally
+ executed will be
+
+ ocamlfind ocamlopt unix.cmxa -package unix myocamlbuild.ml
+
+ which fails with a compilation error due to doubly-passed
+ native modules.
+
+ To sanest way to solve this problem at the ocamlbuild level
+ is to pass "-package unix" instead of unix.cmxa when we
+ detect that such a situation may happen. OCamlfind will see
+ that the same package is demanded twice, and only request
+ it once to the compiler. Similarly, we use "-package
+ ocamlbuild" instead of linking ocamlbuildlib.cmxa[1].
+
+ We switch to this behavior when two conditions, embodied in
+ the boolean variable [use_ocamlfind_pkgs], are met:
+ (a) use-ocamlfind is enabled
+ (b) the user is passing some plugin tags
+
+ Condition (a) is overly conservative as the double-linking
+ issue may also happen in non-ocamlfind situations, such as
+ "-plugin-tags use_unix" -- but it's unclear how one would
+ avoid the issue in that case, except by documenting that
+ people should not do that, or getting rid of the
+ hard-linking logic entirely, with the corresponding risks
+ of regression.
+
+ Condition (b) should not be necessary (we expect using
+ ocamlfind packages to work whenever ocamlfind
+ is available), but allows the behavior in absence
+ of -plugin-tags to be completely unchanged, to reassure us
+ about potential regressions introduced by this option.
+
+ [1]: we may wonder whether to use "-package ocamlbuildlight"
+ in unix-deprived situations, but currently ocamlfind
+ doesn't know about the ocamlbuildlight library. As
+ a compromise we always use "-package ocamlbuild" when
+ use_ocamlfind_pkgs is set. An ocamlfind and -plugin-tags
+ user in unix-deprived environment may want to mutate the
+ META of ocamlbuild to point to ocamlbuildlightlib instead
+ of ocamlbuildlib.
+ *)
+
+ let unix_lib =
+ if use_ocamlfind_pkgs then `Package "unix"
+ else if use_light_mode then `Nothing
+ else `Lib "unix" in
+
+ let ocamlbuild_lib =
+ if use_ocamlfind_pkgs then `Package "ocamlbuild"
+ else if use_light_mode then `Local_lib "ocamlbuildlightlib"
+ else `Local_lib "ocamlbuildlib" in
+
+ let ocamlbuild_module =
+ if use_light_mode then `Local_mod "ocamlbuildlight"
+ else `Local_mod "ocamlbuild" in
+
+ let dir = !Ocamlbuild_where.libdir in
+ let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in
+
+ let in_dir file =
+ let path = dir/file in
+ if not (sys_file_exists path) then failwith
+ (sprintf "Cannot find %S in ocamlbuild -where directory" file);
+ path in
+
+ let spec = function
+ | `Nothing -> N
+ | `Package pkg -> S[A "-package"; A pkg]
+ | `Lib lib -> P (lib -.- cma)
+ | `Local_lib llib -> S [A "-I"; A dir; P (in_dir (llib -.- cma))]
+ | `Local_mod lmod -> P (in_dir (lmod -.- cmo)) in
+
+ (spec unix_lib, spec ocamlbuild_lib, spec ocamlbuild_module)
in
- let ocamlbuildlib = ocamlbuildlib-.-cma in
- let ocamlbuild = ocamlbuild-.-cmo in
- let dir = !Ocamlbuild_where.libdir in
- if not (sys_file_exists (dir/ocamlbuildlib)) then
- failwith (sprintf "Cannot find %S in ocamlbuild -where directory" ocamlbuildlib);
- let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in
+
+ let plugin_tags =
+ Tags.of_list !Options.plugin_tags
+ ++ "ocaml" ++ "program" ++ "link" ++ byte_or_native in
+
+ (* The plugin is compiled before [Param_tags.init()] is called
+ globally, which means that parametrized tags have not been
+ made effective yet. The [partial_init] calls below initializes
+ precisely those that will be used during the compilation of
+ the plugin, and no more.
+ *)
+ Param_tags.partial_init plugin_tags;
+
let cmd =
- Cmd(S[compiler; A"-I"; P dir; libs; more_options;
- P(dir/ocamlbuildlib); plugin_config; P plugin_file;
- P(dir/ocamlbuild); A"-o"; Px (plugin^(!Options.exe))])
+ (* The argument order is important: we carefully put the
+ plugin source files before the ocamlbuild.cm{o,x} module
+ doing the main initialization, so that user global
+ side-effects (setting options, installing flags..) are
+ performed brefore ocamlbuild's main routine. This is
+ a fragile thing to rely upon and we insist that our users
+ use the more robust [dispatch] registration instead, but
+ we still aren't going to break that now.
+
+ For the same reason we place the user plugin-tags after
+ the plugin libraries (in case a tag would, say, inject
+ a .cmo that also relies on them), but before the main
+ plugin source file and ocamlbuild's initialization. *)
+ Cmd(S[compiler;
+ unix_spec; ocamlbuild_lib_spec;
+ T plugin_tags;
+ plugin_config; P plugin_file;
+ ocamlbuild_module_spec;
+ A"-o"; Px (plugin^(!Options.exe))])
in
Shell.chdir !Options.build_dir;
Shell.rm_f (plugin^(!Options.exe));
- Command.execute cmd
+ Command.execute cmd;
+ if !Options.just_plugin then begin
+ Log.finish ();
+ raise Exit_OK;
+ end;
end
let execute_plugin_if_needed () =
begin
rebuild_plugin_if_needed ();
Shell.chdir Pathname.pwd;
- if not !Options.just_plugin then
- let runner = if !Options.native_plugin then N else !Options.ocamlrun in
- let argv = List.tl (Array.to_list Sys.argv) in
- let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe));
- A"-no-plugin"; atomize (List.filter (fun s -> s <> "-plugin-option") argv)] in
- let () = Log.finish () in
- raise (Exit_silently_with_code (sys_command (Command.string_of_command_spec spec)))
+ let runner = if !Options.native_plugin then N else !Options.ocamlrun in
+ let argv = List.tl (Array.to_list Sys.argv) in
+ let passed_argv = List.filter (fun s -> s <> "-plugin-option") argv in
+ let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe));
+ A"-no-plugin"; atomize passed_argv] in
+ Log.finish ();
+ let rc = sys_command (Command.string_of_command_spec spec) in
+ raise (Exit_silently_with_code rc);
end
else
()
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* Plugin *)
val execute_plugin_if_needed : unit -> unit
+val we_need_a_plugin : unit -> bool
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
List.map begin fun x ->
match x with
| A atom -> atom
- | V(var, _) -> List.assoc var env
+ | V(var, _) -> try List.assoc var env with Not_found -> (* unbound variable *) ""
end s
end
end
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
begin match exists2 List.find Resource.Cache.resource_has_changed r.deps with
| Some r -> (`cache_miss_changed_dep r, false)
| _ ->
- begin match exists2 Resources.find Resource.Cache.resource_has_changed dyndeps with
+ begin match exists2 Resources.find_elt Resource.Cache.resource_has_changed dyndeps with
| Some r -> (`cache_miss_changed_dyn_dep r, false)
| _ ->
begin match cached_digest r with
List.fold_right begin fun x acc ->
let r = import x in
if List.mem r acc then
- failwith (sprintf "in rule %s, multiple occurences of the resource %s" name x)
+ failwith (sprintf "in rule %s, multiple occurrences of the resource %s" name x)
else r :: acc
end xs init
in
- if prods = [] && prod = None && stamp = None then raise (Exit_rule_error "Can't make a rule that produce nothing");
+ if prods = [] && prod = None && stamp = None then raise (Exit_rule_error "Can't make a rule that produces nothing");
let stamp, prods =
match stamp with
| None -> None, prods
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
reset_filesys_cache_for_file dest;
run["cp";"-pf";src;dest] dest
-(* L'Arrêté du 2007-03-07 prend en consideration
+(* L'Arrete du 2007-03-07 prend en consideration
differement les archives. Pour les autres fichiers
- le décret du 2007-02-01 est toujours valable :-) *)
+ le decret du 2007-02-01 est toujours valable :-) *)
let cp src dst =
if Filename.check_suffix src ".a"
&& Filename.check_suffix dst ".a"
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
module type SET = sig
include Set.S
- val find : (elt -> bool) -> t -> elt
+ val find_elt : (elt -> bool) -> t -> elt
val map : (elt -> elt) -> t -> t
val of_list : elt list -> t
val print : Format.formatter -> t -> unit
module type TAGS = sig
include Set.S with type elt = string
+ (** [Tags.elt] represents a tag, which is simply a string, usually
+ lowercase, for example "ocaml" or "native". The set of tags
+ attached to a file is computed by applying the tagging rules to
+ the filename. Tagging rules are defined in _tags files in any
+ parent directory of a file, up to the main project directory. *)
+
val of_list : string list -> t
val print : Format.formatter -> t -> unit
val does_match : t -> t -> bool
end
end
-(** Provides an abstract type for easily building complex shell commands without making
- quotation mistakes. *)
+(** Provides an abstract type for easily building complex shell
+ commands without making quotation mistakes. *)
module type COMMAND = sig
type tags
type pathname
(** The type [t] provides some basic combinators and command primitives.
Other commands can be made of command specifications ([spec]). *)
type t =
- | Seq of t list (** A sequence of commands (like the `;' in shell) *)
- | Cmd of spec (** A command is made of command specifications ([spec]) *)
- | Echo of string list * pathname (** Write the given strings (w/ any formatting) to the given file *)
- | Nop (** The command that does nothing *)
+ | Seq of t list (** A sequence of commands (like the `;' in shell) *)
+ | Cmd of spec (** A command is made of command specifications ([spec]) *)
+ | Echo of string list * pathname
+ (** Write the given strings (w/ any formatting) to the given file *)
+ | Nop (** The command that does nothing *)
(** The type for command specifications. That is pieces of command. *)
and spec =
- | N (** No operation. *)
- | S of spec list (** A sequence. This gets flattened in the last stages *)
- | A of string (** An atom. *)
- | P of pathname (** A pathname. *)
- | Px of pathname (** A pathname, that will also be given to the call_with_target hook. *)
- | Sh of string (** A bit of raw shell code, that will not be escaped. *)
- | T of tags (** A set of tags, that describe properties and some semantics
- information about the command, afterward these tags will be
- replaced by command [spec]s (flags for instance). *)
- | V of string (** A virtual command, that will be resolved at execution using [resolve_virtuals] *)
- | Quote of spec (** A string that should be quoted like a filename but isn't really one. *)
+ | N (** No operation. *)
+ | S of spec list (** A sequence. This gets flattened in the last stages *)
+ | A of string (** An atom. *)
+ | P of pathname (** A pathname. *)
+ | Px of pathname (** A pathname, that will also be given to the
+ call_with_target hook. *)
+ | Sh of string (** A bit of raw shell code, that will not be escaped. *)
+ | T of tags (** A set of tags, that describe properties and
+ some semantics information about the
+ command, afterward these tags will be
+ replaced by command [spec]s (flags for
+ instance). *)
+ | V of string (** A virtual command, that will be resolved at
+ execution using [resolve_virtuals] *)
+ | Quote of spec (** A string that should be quoted like a
+ filename but isn't really one. *)
(*type v = [ `Seq of v list | `Cmd of vspec | `Nop ]
- and vspec =
+ and vspec =
[ `N
| `S of vspec list
| `A of string
| `Sh of string
| `Quote of vspec ]
- val spec_of_vspec : vspec -> spec
- val vspec_of_spec : spec -> vspec
- val t_of_v : v -> t
- val v_of_t : t -> v*)
+ val spec_of_vspec : vspec -> spec
+ val vspec_of_spec : spec -> vspec
+ val t_of_v : v -> t
+ val v_of_t : t -> v*)
(** Will convert a string list to a list of atoms by adding [A] constructors. *)
val atomize : string list -> spec
val ( @:= ) : 'a list ref -> 'a list -> unit
val memo : ('a -> 'b) -> ('a -> 'b)
+
+ val memo2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
+
+ val memo3 : ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd)
end
module type OPTIONS = sig
val ocaml_libs : string list ref
val ocaml_mods : string list ref
val ocaml_pkgs : string list ref
+ val ocaml_syntax : string option ref
val ocaml_cflags : string list ref
val ocaml_lflags : string list ref
val ocaml_ppflags : string list ref
(** Same as [link_flags_byte] but for native mode. *)
end
-(** This module contains the functions and values that can be used by plugins. *)
+(** This module contains the functions and values that can be used by
+ plugins. *)
module type PLUGIN = sig
module Pathname : PATHNAME
module Tags : TAGS
module Findlib : FINDLIB with type command_spec = Command.spec
include MISC
- (** See [COMMAND] for the description of these types. *)
- type command = Command.t = Seq of command list | Cmd of spec | Echo of string list * Pathname.t | Nop
+ (** See {!COMMAND.t} for the description of this type. *)
+ type command = Command.t =
+ | Seq of command list
+ | Cmd of spec
+ | Echo of string list * Pathname.t
+ | Nop
+
+ (** See {!COMMAND.spec} for the description of this type. *)
and spec = Command.spec =
| N | S of spec list | A of string | P of string | Px of string
| Sh of string | T of Tags.t | V of string | Quote of spec
if the given option is Some. *)
val ( +++ ) : Tags.t -> Tags.elt option -> Tags.t
- (** [tags---optional_tag] Remove the given optional tag to the given set of tags
- if the given option is Some. *)
+ (** [tags---optional_tag] Remove the given optional tag to the given
+ set of tags if the given option is Some. *)
val ( --- ) : Tags.t -> Tags.elt option -> Tags.t
(** The type of the builder environments. Here an environment is just the
type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list
(** This is the type for rule actions. An action receive as argument, the
- environment lookup function (see [env]), and a function to dynamically
- build more targets (see [builder]). An action should return the command
- to run in order to build the rule productions using the rule dependencies. *)
+ environment lookup function (see {!env}), and a function to dynamically
+ build more targets (see {!builder}). An action should return the command
+ to run in order to build the rule productions using the rule dependencies.
+ *)
type action = env -> builder -> Command.t
(** This is the main function for adding a rule to the ocamlbuild engine.
(** Empties the list of rules of the ocamlbuild engine. *)
val clear_rules : unit -> unit
- (** [dep tags deps] Will build [deps] when all [tags] will be activated. *)
+ (** [dep tags deps] Will build [deps] when all [tags] will be activated.
+ If you do not know which tags to use, have a look to the file
+ _build/_log after trying to compile your code. *)
val dep : Tags.elt list -> Pathname.t list -> unit
- (** [pdep tags ptag deps] is equivalent to [dep tags deps], with an additional
- parameterized tag [ptag]. [deps] is now a function which takes the
- parameter of the tag [ptag] as an argument.
+ (** [pdep tags ptag deps] is equivalent to [dep tags deps], with an
+ additional parameterized tag [ptag]. [deps] is now a function
+ which takes the parameter of the tag [ptag] as an argument.
Example:
[pdep ["ocaml"; "compile"] "autodep" (fun param -> param)]
val pdep : Tags.elt list -> Tags.elt -> (string -> Pathname.t list) -> unit
(** [flag tags command_spec] Will inject the given piece of command
- ([command_spec]) when all [tags] will be activated. *)
+ ([command_spec]) when all [tags] will be activated.
+ If you do not know which tags to use, have a look to the file
+ _build/_log after trying to compile your code. *)
val flag : Tags.elt list -> Command.spec -> unit
(** Allows to use [flag] with a parameterized tag (as [pdep] for [dep]).
(string -> Command.spec) -> unit
(** [non_dependency module_path module_name]
- Example:
+ Example:
[non_dependency "foo/bar/baz" "Goo"]
- Says that the module [Baz] in the file [foo/bar/baz.*] does not depend on [Goo]. *)
+ Says that the module [Baz] in the file [foo/bar/baz.*] does
+ not depend on [Goo]. *)
val non_dependency : Pathname.t -> string -> unit
(** [use_lib module_path lib_path]*)
val use_lib : Pathname.t -> Pathname.t -> unit
- (** [ocaml_lib <options> library_pathname]
- Declare an ocaml library.
+ (** [ocaml_lib <options> library_pathname] Declare an ocaml library.
+ This informs ocamlbuild and produce tags to use the library;
+ they are named by default use_#{library_name}.
- Example: ocaml_lib "foo/bar"
- This will setup the tag use_bar tag.
+ Example: [ocaml_lib "foo/bar"] will setup the tag use_bar.
At link time it will include:
foo/bar.cma or foo/bar.cmxa
- If you supply the ~dir:"boo" option -I boo
- will be added at link and compile time.
- Use ~extern:true for non-ocamlbuild handled libraries.
- Use ~byte:false or ~native:false to disable byte or native mode.
- Use ~tag_name:"usebar" to override the default tag name. *)
+ @param dir supply the [~dir:"boo"] option to add '-I boo'
+ at link and compile time.
+ @param extern use ~extern:true for non-ocamlbuild handled libraries.
+ Set this to add libraries whose sources are not in your project.
+ @param byte use ~byte:false to disable byte mode.
+ @param native use ~native:false to disable native mode.
+ @param tag_name Use ~tag_name:"usebar" to override the default
+ tag name. *)
val ocaml_lib :
?extern:bool ->
?byte:bool ->
(** [expand_module include_dirs module_name extensions]
Example:
- [expand_module ["a";"b";"c"] "Foo" ["cmo";"cmi"] =
- ["a/foo.cmo"; "a/Foo.cmo"; "a/foo.cmi"; "a/Foo.cmi";
- "b/foo.cmo"; "b/Foo.cmo"; "b/foo.cmi"; "b/Foo.cmi";
- "c/foo.cmo"; "c/Foo.cmo"; "c/foo.cmi"; "c/Foo.cmi"]] *)
+ [expand_module ["a";"b";"c"] "Foo" ["cmo";"cmi"] =
+ ["a/foo.cmo"; "a/Foo.cmo"; "a/foo.cmi"; "a/Foo.cmi";
+ "b/foo.cmo"; "b/Foo.cmo"; "b/foo.cmi"; "b/Foo.cmi";
+ "c/foo.cmo"; "c/Foo.cmo"; "c/foo.cmi"; "c/Foo.cmi"]] *)
val expand_module :
Pathname.t list -> Pathname.t -> string list -> Pathname.t list
this package even if it contains that module. *)
val hide_package_contents : string -> unit
- (** [tag_file filename tag_list] Tag the given filename with all given tags. *)
+ (** [tag_file filename tag_list] Tag the given filename with all
+ given tags. Prefix a tag with the minus sign to remove it.
+ This is usually used as an [After_rules] hook.
+ For example [tag_file "bla.ml" ["use_unix"]] tags the file
+ "bla.ml" with "use_unix" and [tag_file "bla.ml" ["-use_unix"]]
+ removes the tag "use_unix" from the file "bla.ml". *)
val tag_file : Pathname.t -> Tags.elt list -> unit
(** [tag_any tag_list] Tag anything with all given tags. *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
let so = "so";;
let exe = "";;
EOF
-ocamlc -c std_signatures.mli
ocamlc -c signatures.mli
ocamlc -c tags.mli
ocamlc -c ocamlbuild_Myocamlbuild_config.ml
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
--- /dev/null
+#load "unix.cma";;
+
+let ocamlbuild = try Sys.getenv "OCAMLBUILD" with Not_found -> "ocamlbuild";;
+
+#use "ocamlbuild_test.ml";;
+
+module M = Match;;
+module T = Tree;;
+
+let _build = M.d "_build";;
+
+test "BasicNativeTree"
+ ~description:"Output tree for native compilation"
+ ~tree:[T.f "dummy.ml"]
+ ~matching:[M.Exact
+ (_build
+ (M.lf
+ ["_digests";
+ "dummy.cmi";
+ "dummy.cmo";
+ "dummy.cmx";
+ "dummy.ml";
+ "dummy.ml.depends";
+ "dummy.native";
+ "dummy.o";
+ "_log"]))]
+ ~targets:("dummy.native",[]) ();;
+
+test "BasicByteTree"
+ ~description:"Output tree for byte compilation"
+ ~tree:[T.f "dummy.ml"]
+ ~matching:[M.Exact
+ (_build
+ (M.lf
+ ["_digests";
+ "dummy.cmi";
+ "dummy.cmo";
+ "dummy.ml";
+ "dummy.ml.depends";
+ "dummy.byte";
+ "_log"]))]
+ ~targets:("dummy.byte",[]) ();;
+
+test "SeveralTargets"
+ ~description:"Several targets"
+ ~tree:[T.f "dummy.ml"]
+ ~matching:[_build (M.lf ["dummy.byte"; "dummy.native"])]
+ ~targets:("dummy.byte",["dummy.native"]) ();;
+
+let alt_build_dir = "BuIlD2";;
+
+test "BuildDir"
+ ~options:[`build_dir alt_build_dir]
+ ~description:"Different build directory"
+ ~tree:[T.f "dummy.ml"]
+ ~matching:[M.d alt_build_dir (M.lf ["dummy.byte"])]
+ ~targets:("dummy.byte",[]) ();;
+
+test "camlp4.opt"
+ ~description:"Fixes PR#5652"
+ ~options:[`use_ocamlfind; `package "camlp4.macro";`tags ["camlp4o.opt"; "syntax\\(camp4o\\)"];
+ `ppflag "camlp4o.opt"; `ppflag "-parser"; `ppflag "macro"; `ppflag "-DTEST"]
+ ~tree:[T.f "dummy.ml" ~content:"IFDEF TEST THEN\nprint_endline \"Hello\";;\nENDIF;;"]
+ ~matching:[M.x "dummy.native" ~output:"Hello"]
+ ~targets:("dummy.native",[]) ();;
+
+test "ThreadAndArchive"
+ ~description:"Fixes PR#6058"
+ ~options:[`use_ocamlfind; `package "threads"; `tag "thread"]
+ ~tree:[T.f "t.ml" ~content:""]
+ ~matching:[M.f "_build/t.cma"]
+ ~targets:("t.cma",[]) ();;
+
+let tag_pat_msgs =
+ ["*:a", "File \"_tags\", line 1, column 0: Lexing error: Invalid globbing pattern \"*\".";
+ "\n<*{>:a", "File \"_tags\", line 2, column 0: Lexing error: Invalid globbing pattern \"<*{>\".";
+ "<*>: ~@a,# ~a", "File \"_tags\", line 1, column 10: Lexing error: Only ',' separated tags are alllowed."];;
+
+List.iteri (fun i (content,failing_msg) ->
+ test (Printf.sprintf "TagsErrorMessage_%d" (i+1))
+ ~description:"Confirm relevance of an error message due to erronous _tags"
+ ~failing_msg
+ ~tree:[T.f "_tags" ~content; T.f "dummy.ml"]
+ ~targets:("dummy.native",[]) ()) tag_pat_msgs;;
+
+test "SubtoolOptions"
+ ~description:"Options that come from tags that needs to be spliced to the subtool invocation (PR#5763)"
+ ~options:[`use_menhir; `use_ocamlfind; `tags["package\\(camlp4.fulllib\\)"]]
+ ~tree:[T.f "parser.mly" ~content:"%{\n%}\n%token DUMMY\n%start<Camlp4.PreCast.Syntax.Ast.expr option> test%%test: {None}\n\n"]
+ ~matching:[M.f "parser.native"; M.f "parser.byte"]
+ ~targets:("parser.native",["parser.byte"])
+ ();;
+
+test "Itarget"
+ ~description:".itarget building with dependencies between the modules (PR#5686)"
+ ~tree:[T.f "foo.itarget" ~content:"a.cma\nb.byte\n"; T.f "a.ml"; T.f "b.ml" ~content:"open A\n"]
+ ~matching:[M.f "a.cma"; M.f "b.byte"]
+ ~targets:("foo.otarget",[]) ();;
+
+test "PackAcross"
+ ~description:"Pack using a module from the other tree (PR#4592)"
+ ~tree:[T.f "main.ml" ~content:"let _ = Pack.Packed.g ()\n";
+ T.f "Pack.mlpack" ~content:"pack/Packed";
+ T.f "_tags" ~content:"<lib>: include\n<pack/*.cmx>: for-pack(Pack)\n";
+ T.d "lib" [T.f "Lib.ml" ~content:"let f()=()";
+ T.f "Lib.mli" ~content:"val f : unit -> unit"];
+ T.d "pack" [T.f "Packed.ml" ~content:"let g() = Lib.f ()"]]
+ ~matching:[M.f "main.byte"; M.f "main.native"]
+ ~targets:("main.byte", ["main.native"])
+ ();;
+
+test "PackAcross2"
+ ~description:"Pack using a module from the other tree (PR#4592)"
+ ~tree:[T.f "a2.mli" ~content:"val f : unit -> unit";
+ T.f "a2.ml" ~content:"let f _ = ()";
+ T.f "lib.ml" ~content:"module A = A2";
+ T.f "b.ml" ~content:"let g = Lib.A.f";
+ T.f "sup.mlpack" ~content:"B";
+ T.f "prog.ml" ~content:"Sup.B.g"]
+ ~matching:[M.f "prog.byte"]
+ ~targets:("prog.byte",[]) ();;
+
+test "PackAcross3"
+ ~description:"Pack using a module from the other tree (PR#4592)"
+ ~tree:[T.d "foo" [ T.f "bar.ml" ~content:"let baz = Quux.xyzzy"];
+ T.f "foo.mlpack" ~content:"foo/Bar";
+ T.f "main.ml" ~content:"prerr_endline Foo.Bar.baz";
+ T.f "myocamlbuild.ml";
+ T.f "quux.ml" ~content:"let xyzzy = \"xyzzy\"";
+ T.f "quux.mli" ~content:"val xyzzy : string"]
+ ~matching:[M.f "main.byte"]
+ ~targets:("main.byte",[]) ();;
+
+test "SyntaxFlag"
+ ~description:"-syntax for ocamlbuild"
+ ~options:[`use_ocamlfind; `package "camlp4.macro"; `syntax "camlp4o"]
+ ~tree:[T.f "dummy.ml" ~content:"IFDEF TEST THEN\nprint_endline \"Hello\";;\nENDIF;;"]
+ ~matching:[M.f "dummy.native"]
+ ~targets:("dummy.native",[]) ();;
+
+test "NoIncludeNoHygiene1"
+ ~description:"check that hygiene checks are only done in traversed directories\
+ (PR#4502)"
+ ~tree:[T.d "must_ignore" [ T.f "dirty.mli" ~content:"val bug : int"];
+ T.f "hello.ml" ~content:"print_endline \"Hello, World!\"";
+ T.f "_tags" ~content:"<must_ignore>: -traverse"]
+ ~pre_cmd:"ocamlc -c must_ignore/dirty.mli"
+ (* will make hygiene fail if must_ignore/ is checked *)
+ ~targets:("hello.byte",[]) ();;
+
+test "NoIncludeNoHygiene2"
+ ~description:"check that hygiene checks are not done on the -build-dir \
+ (PR#4502)"
+ ~tree:[T.d "must_ignore" [ T.f "dirty.mli" ~content:"val bug : int"];
+ T.f "hello.ml" ~content:"print_endline \"Hello, World!\"";
+ T.f "_tags" ~content:""]
+ ~options:[`build_dir "must_ignore"]
+ ~pre_cmd:"ocamlc -c must_ignore/dirty.mli"
+ (* will make hygiene fail if must_ignore/ is checked *)
+ ~targets:("hello.byte",[]) ();;
+
+test "NoIncludeNoHygiene3"
+ ~description:"check that hygiene checks are not done on excluded dirs (PR#4502)"
+ ~tree:[T.d "must_ignore" [ T.f "dirty.mli" ~content:"val bug : int"];
+ T.f "hello.ml" ~content:"print_endline \"Hello, World!\"";
+ T.f "_tags" ~content:""]
+ ~options:[`X "must_ignore"]
+ ~pre_cmd:"ocamlc -c must_ignore/dirty.mli"
+ (* will make hygiene fail if must_ignore/ is checked *)
+ ~targets:("hello.byte",[]) ();;
+
+test "OutputObj"
+ ~description:"output_obj targets for native and bytecode (PR #6049)"
+ ~tree:[T.f "hello.ml" ~content:"print_endline \"Hello, World!\""]
+ ~targets:("hello.byte.o",["hello.byte.c";"hello.native.o"]) ();;
+
+test "StrictSequenceFlag"
+ ~description:"-strict_sequence tag"
+ ~tree:[T.f "hello.ml" ~content:"let () = 1; ()";
+ T.f "_tags" ~content:"true: strict_sequence\n"]
+ ~options:[`quiet]
+ ~failing_msg:"File \"hello.ml\", line 1, characters 9-10:
+Error: This expression has type int but an expression was expected of type
+ unit\nCommand exited with code 2."
+ ~targets:("hello.byte",[]) ();;
+
+test "PrincipalFlag"
+ ~description:"-principal tag"
+ ~tree:[T.f "hello.ml" ~content:"type s={foo:int;bar:unit} type t={foo:int} let f x = x.bar;x.foo";
+ T.f "_tags" ~content:"true: principal\n"]
+ ~options:[`quiet]
+ ~failing_msg:"File \"hello.ml\", line 1, characters 61-64:
+Warning 18: this type-based field disambiguation is not principal."
+ ~targets:("hello.byte",[]) ();;
+
+test "ModularPlugin1"
+ ~options:[`quiet; `plugin_tag "use_str"]
+ ~description:"test a plugin with dependency on external libraries"
+ ~tree:[T.f "main.ml" ~content:"let x = 1";
+ T.f "myocamlbuild.ml" ~content:"ignore (Str.quote \"\");;"]
+ ~matching:[M.f "main.byte"]
+ ~targets:("main.byte",[]) ();;
+
+test "ModularPlugin2"
+ ~description:"check that parametrized tags defined by the plugin
+ do not warn at plugin-compilation time"
+ ~options:[`quiet]
+ ~tree:[T.f "main.ml" ~content:"let x = 1";
+ T.f "_tags" ~content:"<main.*>: toto(-g)";
+ T.f "myocamlbuild.ml"
+ ~content:"open Ocamlbuild_plugin;;
+ pflag [\"link\"] \"toto\" (fun arg -> A arg);;"]
+ ~failing_msg:""
+ ~matching:[M.f "main.byte"]
+ ~targets:("main.byte",[]) ();;
+
+test "ModularPlugin3"
+ ~description:"check that unknown parametrized tags encountered
+ during plugin compilation still warn"
+ ~options:[`quiet; `plugin_tag "'toto(-g)'"]
+ ~tree:[T.f "main.ml" ~content:"let x = 1";
+ T.f "myocamlbuild.ml"
+ ~content:"open Ocamlbuild_plugin;;
+ pflag [\"link\"] \"toto\" (fun arg -> A arg);;"]
+ ~failing_msg:"Warning: tag \"toto\" does not expect a parameter, \
+ but is used with parameter \"-g\""
+ ~matching:[M.f "main.byte"]
+ ~targets:("main.byte",[]) ();;
+
+run ~root:"_test";;
--- /dev/null
+(***********************************************************************)
+(* *)
+(* ocamlbuild *)
+(* *)
+(* Wojciech Meyer *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Format
+
+external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+
+let print_list ~sep f ppf = function
+| [] -> ()
+| x :: [] -> f ppf x
+| x :: xs -> f ppf x; List.iter (fun x -> sep ppf (); f ppf x) xs
+
+let print_list_com f = print_list ~sep:(fun ppf () -> pp_print_string ppf ",") f
+let print_list_blank f = print_list ~sep:(fun ppf () -> pp_print_string ppf " ") f
+let print_string_list = print_list_com pp_print_string
+let print_string_list_com = print_list_com pp_print_string
+let print_string_list_blank = print_list_blank pp_print_string
+
+let exists filename =
+ try ignore(Unix.stat filename); true
+ with Unix.Unix_error ((Unix.ENOENT),_,_) -> false
+
+let execute cmd =
+ let ic = Unix.open_process_in cmd and lst = ref [] in
+ try while true do lst := input_line ic :: !lst done; assert false
+ with End_of_file ->
+ let ret_code = Unix.close_process_in ic
+ in ret_code, List.rev !lst
+
+let rm f =
+ if exists f then
+ ignore(Sys.command (Printf.sprintf "rm -r %s" f))
+
+module Match = struct
+
+ type atts = unit
+
+ (* File consists of file attribute and name *)
+ type file = atts * string
+
+ (* Result is an outcome of execution, if consists of returned exit code,
+ and stream from stdout *)
+ type result = int * string
+
+ type t =
+ (* Represents file in the tree *)
+ | F of file
+ (* Directory, consists of name and sub entries *)
+ | D of file * t list
+ (* Like file, but will be executed, and the result will compared *)
+ | X of file * result
+ (* Symlink *)
+ | L of file * file
+ (* We request that everything below should match exactly *)
+ | Exact of t
+ (* Here we want just the tree contained entities but we allow some
+ other stuff to be there too *)
+ | Contains of t
+ (* Any means that we match anything *)
+ | Any
+ (* Empty a tree leaf that don't match at all *)
+ | Empty
+
+ (* Type of error, we either expect something or something is un-expected *)
+ type error =
+ Expected of string
+ | Unexpected of string
+ | Structure of string * string list
+ | Output of string * string
+
+ (* This will print the tree *)
+ let print ppf tree =
+ let rec lines ppf lst =
+ List.iter (fun line -> pp_print_space ppf (); item ppf line) lst
+ and item ppf = function
+ | F (_, name) -> fprintf ppf "@[<h>%s@]" name
+ | D ((_, name), children) -> fprintf ppf "@[<v 1>@[<h>%s/@]%a@]" name lines children
+ | X ((_,name), _) -> fprintf ppf "@[<h>%s@]" name
+ | L ((_,src), (_,dst)) -> fprintf ppf "@[<h>%s->%s@]@" src dst
+ | Exact content -> fprintf ppf "{%a}" item content
+ | Contains content -> fprintf ppf "<%a>" item content
+ | Any -> pp_print_char ppf '*'
+ | Empty -> pp_print_char ppf '#'
+ in
+ pp_open_vbox ppf 0;
+ item ppf tree;
+ pp_close_box ppf ()
+
+ let f ?(atts=()) name = F (atts, name)
+ let d ?(atts=()) name children = D ((atts, name), children)
+ let lf ?(atts=()) lst = List.map (fun nm -> F (atts,nm)) lst
+ let x ?(atts=()) name ~output = X ((atts,name), (0,output))
+
+ let match_with_fs ~root m =
+
+ let errors = ref [] in
+
+ let rec visit ~exact path m =
+ let file name =
+ "./" ^ (List.rev (name :: path) |> String.concat "/")
+
+ in
+
+ let exists_assert filename =
+ if not (exists (file filename)) then
+ errors := Expected filename :: !errors;
+ in
+
+ let take_name = function
+ | F (_, name)
+ | D ((_, name),_) -> [name]
+ | _ -> []
+ in
+
+ match m with
+ | F ((),name) ->
+ exists_assert name
+ | D (((),name), sub) ->
+ exists_assert name;
+ let lst = List.flatten (List.map take_name sub) in
+ let lst' = Sys.readdir name |> Array.to_list in
+ let lst' = List.filter (fun x -> not (List.mem x lst)) lst' in
+ (if exact && lst' <> [] then
+ errors := Structure ((file name), lst') :: !errors);
+ List.iter (visit ~exact (name :: path)) sub
+ | X (((), name), (retcode, output)) ->
+ let _,output' = execute (file name) in
+ let output' = String.concat "\n" output' in
+ if output <> output' then
+ errors := Output (output, output') :: !errors
+ | Exact sub -> visit ~exact:true path sub
+ | Contains sub -> visit ~exact:false path sub
+ | _ -> assert false
+ in
+ let dir = Sys.getcwd () in
+ Unix.chdir root;
+ visit ~exact:false [] m;
+ Unix.chdir dir;
+ List.rev !errors
+
+ let string_of_error = function
+ | Expected s -> Printf.sprintf "expected '%s' on a file system" s
+ | Unexpected s -> Printf.sprintf "un-expected '%s' on a file system" s
+ | Structure (s,l) -> Printf.sprintf "directory structure '%s' has un-expected files %s" s (String.concat ", " l)
+ | Output (e, p) -> Printf.sprintf "not matching output '%s' expected but got %s" e p
+end
+
+module Option = struct
+
+ type flag = string
+ type path = string
+ type level = int
+ type package = string
+ type file = string
+ type command = string
+ type _module = string
+ type tag = string
+
+ type t =
+ [ `version
+ | `vnum
+ | `quiet
+ | `verbose of level
+ | `documentation
+ | `log of file
+ | `no_log
+ | `clean
+ | `r
+ | `I of path
+ | `Is of path list
+ | `X of path
+ | `Xs of path list
+ | `lib of flag
+ | `libs of flag list
+ | `_mod of _module
+ | `mods of _module list
+ | `pkg of package
+ | `pkgs of package list
+ | `package of package
+ | `syntax of string
+ | `lflag of flag
+ | `lflags of flag list
+ | `cflag of flag
+ | `cflags of flag list
+ | `docflag of flag
+ | `docflags of flag list
+ | `yaccflag of flag
+ | `yaccflags of flag list
+ | `lexflag of flag
+ | `lexflags of flag list
+ | `ppflag of flag
+ | `pp of flag list
+ | `tag of tag
+ | `tags of tag list
+ | `plugin_tag of tag
+ | `plugin_tags of tag list
+ | `tag_line of tag
+ | `show_tags of path
+ | `ignore of _module list
+ | `no_links
+ | `no_skip
+ | `no_hygiene
+ | `no_plugin
+ | `no_stdlib
+ | `dont_catch_errors
+ | `just_plugin
+ | `byte_plugin
+ | `plugin_option
+ | `sanitization_script
+ | `no_sanitize
+ | `nothing_should_be_rebuilt
+ | `classic_display
+ | `use_menhir
+ | `use_jocaml
+ | `use_ocamlfind
+ | `j of level
+ | `build_dir of path
+ | `install_lib_dir of path
+ | `install_bin_dir of path
+ | `where
+ | `ocamlc of command
+ | `ocamlopt of command
+ | `ocamldep of command
+ | `ocamldoc of command
+ | `ocamlyacc of command
+ | `menhir of command
+ | `ocamllex of command
+ | `ocamlmktop of command
+ | `ocamlrun of command
+ | `help ]
+
+ type arg = string * string list
+
+ let print_level = pp_print_int
+ let print_flag = pp_print_string
+ let print_package = pp_print_string
+ let print_tag = pp_print_string
+ let print_tags = print_string_list_com
+ let print_path = pp_print_string
+ let print_paths = print_string_list_com
+ let print_flags = print_string_list_com
+ let print_module = pp_print_string
+ let print_modules = print_string_list_com
+ let print_packages = print_string_list_com
+ let print_command = pp_print_string
+
+ let print_opt ppf o =
+ fprintf ppf "-";
+ match o with
+ | `version -> fprintf ppf "version"
+ | `vnum -> fprintf ppf "vnum"
+ | `quiet -> fprintf ppf "quiet"
+ | `verbose level -> fprintf ppf "verbose %a" print_level level
+ | `documentation -> fprintf ppf "documentation"
+ | `log file -> fprintf ppf "log"
+ | `no_log -> fprintf ppf "no-log"
+ | `clean -> fprintf ppf "clean"
+ | `r -> fprintf ppf "r"
+ | `I path -> fprintf ppf "I %a" print_path path
+ | `Is paths -> fprintf ppf "Is %a" print_paths paths
+ | `X path -> fprintf ppf "X %a" print_path path
+ | `Xs paths -> fprintf ppf "Xs %a" print_paths paths
+ | `lib flag -> fprintf ppf "lib %a" print_flag flag
+ | `libs flags -> fprintf ppf "libs %a" print_flags flags
+ | `_mod _module -> fprintf ppf "mod %a" print_module _module
+ | `mods _modules -> fprintf ppf "mods %a" print_modules _modules
+ | `pkg package -> fprintf ppf "pkg %a" print_package package
+ | `pkgs packages -> fprintf ppf "pkgs %a" print_packages packages
+ | `package package -> fprintf ppf "package %a" print_package package
+ | `syntax syntax -> fprintf ppf "syntax %a" pp_print_string syntax
+ | `lflag flag -> fprintf ppf "lflag %a" print_flag flag
+ | `lflags flags -> fprintf ppf "lflags %a" print_flags flags
+ | `cflag flag -> fprintf ppf "cflag %a" print_flag flag
+ | `cflags flags -> fprintf ppf "cflags %a" print_flags flags
+ | `docflag flag -> fprintf ppf "docflag %a" print_flag flag
+ | `docflags flags -> fprintf ppf "docflags %a" print_flags flags
+ | `yaccflag flag -> fprintf ppf "yaccflag %a" print_flag flag
+ | `yaccflags flags -> fprintf ppf "yaccflags %a" print_flags flags
+ | `lexflag flag -> fprintf ppf "lexflag %a" print_flag flag
+ | `lexflags flags -> fprintf ppf "lexflags %a" print_flags flags
+ | `ppflag flag -> fprintf ppf "ppflag %a" print_flag flag
+ | `pp flags -> fprintf ppf "pp %a" print_flags flags
+ | `tag tag -> fprintf ppf "tag %a" print_tag tag
+ | `tags tags -> fprintf ppf "tags %a" print_tags tags
+ | `plugin_tag tag -> fprintf ppf "plugin-tag %a" print_tag tag
+ | `plugin_tags tags -> fprintf ppf "plugin-tags %a" print_tags tags
+ | `tag_line tag -> fprintf ppf "tag-line %a" print_tag tag
+ | `show_tags path -> fprintf ppf "show-tags %a" print_path path
+ | `ignore _modules -> fprintf ppf "ignore %a" print_modules _modules
+ | `no_links -> fprintf ppf "no-links"
+ | `no_skip -> fprintf ppf "no-skip"
+ | `no_hygiene -> fprintf ppf "no-hygiene"
+ | `no_plugin -> fprintf ppf "no-pluging"
+ | `no_stdlib -> fprintf ppf "no-stdlib"
+ | `dont_catch_errors -> fprintf ppf "dont"
+ | `just_plugin -> fprintf ppf "just-plugin"
+ | `byte_plugin -> fprintf ppf "byte-plugin"
+ | `plugin_option -> fprintf ppf "plugin-option"
+ | `sanitization_script -> fprintf ppf "sanitization-script"
+ | `no_sanitize -> fprintf ppf "no-sanitze"
+ | `nothing_should_be_rebuilt -> fprintf ppf "nothing_should_be_rebuilt"
+ | `classic_display -> fprintf ppf "classic-display"
+ | `use_menhir -> fprintf ppf "use-menhir"
+ | `use_jocaml -> fprintf ppf "use-jocaml"
+ | `use_ocamlfind -> fprintf ppf "use-ocamlfind"
+ | `j level -> fprintf ppf "j %a" print_level level
+ | `build_dir path -> fprintf ppf "build-dir %a" print_path path
+ | `install_lib_dir path -> fprintf ppf "install %a" print_path path
+ | `install_bin_dir path -> fprintf ppf "install %a" print_path path
+ | `where -> fprintf ppf "where"
+ | `ocamlc command -> fprintf ppf "ocamlc %a" print_command command
+ | `ocamlopt command -> fprintf ppf "ocamlopt %a" print_command command
+ | `ocamldep command -> fprintf ppf "ocamldep %a" print_command command
+ | `ocamldoc command -> fprintf ppf "ocamldoc %a" print_command command
+ | `ocamlyacc command -> fprintf ppf "ocamlyacc %a" print_command command
+ | `menhir command -> fprintf ppf "menhir %a" print_command command
+ | `ocamllex command -> fprintf ppf "ocamllex %a" print_command command
+ | `ocamlmktop command -> fprintf ppf "ocamlmktop %a" print_command command
+ | `ocamlrun command -> fprintf ppf "ocamlrun %a" print_command command
+ | `help -> fprintf ppf "help"
+
+end
+
+module Tree = struct
+
+ type name = string
+ type content = string
+
+ type t =
+ F of name * content
+ | D of name * t list
+ | E
+
+ let f ?(content="") name = F (name, content)
+ let d name children = D (name, children)
+
+ let create_on_fs ~root f =
+
+ let rec visit path f =
+ let file name =
+ List.rev (name :: path)
+ |> String.concat "/"
+ in
+ match f with
+ | F (name, content) ->
+ let ch = file name |> open_out in
+ output_string ch content;
+ close_out ch
+ | D (name, sub) ->
+ (* print_endline ("mking " ^ (file name)); *)
+ Unix.mkdir (file name) 0o750;
+ List.iter (visit (name :: path)) sub
+ | E -> ()
+ in
+
+ let dir = Sys.getcwd () in
+ Unix.chdir root;
+ visit [] f;
+ Unix.chdir dir
+
+end
+
+type content = string
+type filename = string
+type run = filename * content
+
+type test = { name : string
+ ; description : string
+ ; tree : Tree.t list
+ ; matching : Match.t list
+ ; options : Option.t list
+ ; targets : string * string list
+ ; pre_cmd : string option
+ ; failing_msg : string option
+ ; run : run list }
+
+let tests = ref []
+
+let test name
+ ~description
+ ?(options=[]) ?(run=[]) ?pre_cmd ?failing_msg
+ ?(tree=[])
+ ?(matching=[])
+ ~targets ()
+ =
+ tests := !tests @ [{ name; description; tree; matching; options; targets; pre_cmd; failing_msg; run }]
+
+let run ~root =
+ let dir = Sys.getcwd () in
+ let root = dir ^ "/" ^ root in
+ rm root;
+ Unix.mkdir root 0o750;
+
+ let command opts args =
+ let b = Buffer.create 127 in
+ let f = Format.formatter_of_buffer b in
+ fprintf f "%s %a %a" ocamlbuild (print_list_blank Option.print_opt) opts (print_list_blank pp_print_string) args;
+ Format.pp_print_flush f ();
+ Buffer.contents b
+ in
+
+ let one_test
+ { name
+ ; description
+ ; tree
+ ; matching
+ ; options
+ ; targets
+ ; failing_msg
+ ; pre_cmd
+ ; run } =
+
+ let full_name = root ^ "/" ^ name in
+ rm full_name;
+ Unix.mkdir full_name 0o750;
+ List.iter (Tree.create_on_fs ~root:full_name) tree;
+ Unix.chdir full_name;
+
+ (match pre_cmd with
+ | None -> ()
+ | Some str -> ignore(Sys.command str));
+
+ let log_name = full_name ^ ".log" in
+
+ let cmd = command options (fst targets :: snd targets) in
+ let allow_failure = failing_msg <> None in
+
+ Unix.(match execute cmd with
+ | WEXITED n,lines
+ | WSIGNALED n,lines
+ | WSTOPPED n,lines when allow_failure || n <> 0 ->
+ begin match failing_msg with
+ | None ->
+ let ch = open_out log_name in
+ List.iter (fun l -> output_string ch l; output_string ch "\n") lines;
+ close_out ch;
+ Printf.printf "\x1b[0;31m\x1b[1m[FAILED]\x1b[0m \x1b[1m%-20s\x1b[0;33m%s.\n\x1b[m%!" name
+ (Printf.sprintf "Command '%s' with error code %n output written to %s" cmd n log_name);
+ | Some failing_msg ->
+ let starts_with_plus s = String.length s > 0 && s.[0] = '+' in
+ let lines = List.filter (fun s -> not (starts_with_plus s)) lines in
+ let msg = String.concat "\n" lines in
+ if failing_msg = msg then
+ Printf.printf "\x1b[0;32m\x1b[1m[PASSED]\x1b[0m \x1b[1m%-20s\x1b[0;36m%s.\n\x1b[m%!" name description
+ else
+ Printf.printf "\x1b[0;31m\x1b[1m[FAILED]\x1b[0m \x1b[1m%-20s\x1b[0;33m%s.\n\x1b[m%!" name ((Printf.sprintf "Failure with not matching message:\n%s\n!=\n%s\n") msg failing_msg)
+ end;
+ | _ ->
+ let errors = List.concat (List.map (Match.match_with_fs ~root:full_name) matching) in
+ begin if errors == [] then
+ Printf.printf "\x1b[0;32m\x1b[1m[PASSED]\x1b[0m \x1b[1m%-20s\x1b[0;36m%s.\n\x1b[m%!" name description
+ else begin
+ let ch = open_out log_name in
+ output_string ch ("Run '" ^ cmd ^ "'\n");
+ List.iter (fun e -> output_string ch (Match.string_of_error e); output_string ch ".\n") errors;
+ close_out ch;
+ Printf.printf "\x1b[0;31m\x1b[1m[FAILED]\x1b[0m \x1b[1m%-20s\x1b[0;33m%s.\n\x1b[m%!" name
+ (Printf.sprintf "Some system checks failed, output written to %s" log_name)
+ end
+ end)
+
+ in List.iter one_test !tests
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \
../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \
../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \
- ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \
- odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
+ ../parsing/syntaxerr.cmi ../driver/pparse.cmi ../parsing/parse.cmi \
+ odoc_types.cmi odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \
odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \
../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \
../utils/config.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \
- ../utils/ccomp.cmi odoc_analyse.cmi
+ odoc_analyse.cmi
odoc_analyse.cmx : ../utils/warnings.cmx ../typing/typetexp.cmx \
../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \
../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \
../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \
- ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \
- odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
+ ../parsing/syntaxerr.cmx ../driver/pparse.cmx ../parsing/parse.cmx \
+ odoc_types.cmx odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \
odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \
../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \
../utils/config.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \
- ../utils/ccomp.cmx odoc_analyse.cmi
+ odoc_analyse.cmi
odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \
odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \
odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi
#(***********************************************************************)
+#(* *)
#(* OCamldoc *)
#(* *)
#(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
#(* *)
#(***********************************************************************)
-# $Id: Makefile 12707 2012-07-13 11:23:13Z doligez $
-
include ../config/Makefile
# Various commands and dir
OCAMLDOC_LIBCMA=odoc_info.cma
OCAMLDOC_LIBCMI=odoc_info.cmi
OCAMLDOC_LIBCMXA=odoc_info.cmxa
-OCAMLDOC_LIBA=odoc_info.a
+OCAMLDOC_LIBA=odoc_info.$(A)
INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc
INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom
INSTALL_BINDIR=$(OCAMLBIN)
GENERATORS_CMOS= \
generators/odoc_todo.cmo \
generators/odoc_literate.cmo
-GENERATORS_CMXS_TMP1=$(GENERATORS_CMOS:.cmo=.cmxs)
-GENERATORS_CMXS_TMP2=$(NATDYNLINK:false=)
-GENERATORS_CMXS=$(GENERATORS_CMXS_TMP2:true=$(GENERATORS_CMXS_TMP1))
+true = $(GENERATORS_CMOS:.cmo=.cmxs)
+false =
+GENERATORS_CMXS := $($(NATDYNLINK))
# Compilation
odoc_texi.cmo \
odoc_dot.cmo \
odoc_gen.cmo \
- odoc_args.cmo\
+ odoc_args.cmo \
odoc.cmo
EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
$(OCAMLSRCDIR)/typing/typedtree.cmo \
$(OCAMLSRCDIR)/typing/parmatch.cmo \
$(OCAMLSRCDIR)/typing/stypes.cmo \
+ $(OCAMLSRCDIR)/typing/typedtreeMap.cmo \
$(OCAMLSRCDIR)/typing/cmt_format.cmo \
$(OCAMLSRCDIR)/typing/typecore.cmo \
$(OCAMLSRCDIR)/typing/includeclass.cmo \
$(OCAMLSRCDIR)/bytecomp/translobj.cmo \
$(OCAMLSRCDIR)/bytecomp/translcore.cmo \
$(OCAMLSRCDIR)/bytecomp/translclass.cmo \
- $(OCAMLSRCDIR)/tools/depend.cmo
+ $(OCAMLSRCDIR)/tools/depend.cmo \
+ $(OCAMLSRCDIR)/driver/pparse.cmo
OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx)
clean:: dummy
@rm -f *~ \#*\#
- @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o
+ @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O)
@rm -f odoc_parser.output odoc_text_parser.output
@rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
@rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
@rm -rf stdlib_man
- @rm -f generators/*.cm[aiox] generators/*.[ao] generators/*.cmx[as]
+ @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as]
depend::
$(OCAMLYACC) odoc_text_parser.mly
#(***********************************************************************)
+#(* *)
#(* OCamldoc *)
#(* *)
#(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
#(* *)
#(***********************************************************************)
-# $Id: Makefile.nt 12692 2012-07-10 15:20:34Z doligez $
-
include ../config/Makefile
-CAMLRUN =../boot/ocamlrun
+# Various commands and dir
+##########################
+CAMLRUN=../boot/ocamlrun
OCAMLC = ../ocamlcomp.sh
OCAMLOPT = ../ocamlcompopt.sh
-OCAMLLEX =$(CAMLRUN) ../boot/ocamllex
-OCAMLYACC=../boot/ocamlyacc
-
+OCAMLDEP = $(CAMLRUN) ../tools/ocamldep
+OCAMLLEX = $(CAMLRUN) ../boot/ocamllex
+OCAMLYACC= ../boot/ocamlyacc
OCAMLLIB = $(LIBDIR)
OCAMLBIN = $(BINDIR)
INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
-COMPFLAGS=$(INCLUDES)
+COMPFLAGS=$(INCLUDES) -warn-error A
LINKFLAGS=$(INCLUDES) -nostdlib
CMOFILES= odoc_config.cmo \
CMXFILES= $(CMOFILES:.cmo=.cmx)
CMIFILES= $(CMOFILES:.cmo=.cmi)
-EXECMOFILES=$(CMOFILES)\
- odoc_dag2html.cmo\
- odoc_to_text.cmo\
- odoc_ocamlhtml.cmo\
- odoc_html.cmo\
- odoc_man.cmo\
+EXECMOFILES=$(CMOFILES) \
+ odoc_dag2html.cmo \
+ odoc_to_text.cmo \
+ odoc_ocamlhtml.cmo \
+ odoc_html.cmo \
+ odoc_man.cmo \
odoc_latex_style.cmo \
- odoc_latex.cmo\
- odoc_texi.cmo\
- odoc_dot.cmo\
- odoc_gen.cmo\
- odoc_args.cmo\
+ odoc_latex.cmo \
+ odoc_texi.cmo \
+ odoc_dot.cmo \
+ odoc_gen.cmo \
+ odoc_args.cmo \
odoc.cmo
$(OCAMLSRCDIR)/typing/typedtree.cmo \
$(OCAMLSRCDIR)/typing/parmatch.cmo \
$(OCAMLSRCDIR)/typing/stypes.cmo \
+ $(OCAMLSRCDIR)/typing/typedtreeMap.cmo \
$(OCAMLSRCDIR)/typing/cmt_format.cmo \
$(OCAMLSRCDIR)/typing/typecore.cmo \
$(OCAMLSRCDIR)/typing/includeclass.cmo \
$(OCAMLSRCDIR)/bytecomp/translobj.cmo \
$(OCAMLSRCDIR)/bytecomp/translcore.cmo \
$(OCAMLSRCDIR)/bytecomp/translclass.cmo \
- $(OCAMLSRCDIR)/tools/depend.cmo
+ $(OCAMLSRCDIR)/tools/depend.cmo \
+ $(OCAMLSRCDIR)/driver/pparse.cmo
OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx)
$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
$(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES)
+# Parsers and lexers dependencies :
+###################################
+odoc_text_parser.ml: odoc_text_parser.mly
+odoc_text_parser.mli: odoc_text_parser.mly
+
+odoc_parser.ml: odoc_parser.mly
+odoc_parser.mli:odoc_parser.mly
+
+odoc_text_lexer.ml: odoc_text_lexer.mll
+
+odoc_lexer.ml:odoc_lexer.mll
+
+odoc_ocamlhtml.ml: odoc_ocamlhtml.mll
+
+odoc_see_lexer.ml: odoc_see_lexer.mll
+
+
# generic rules :
#################
-.SUFFIXES: .mli .ml .cmi .cmo .cmx
+.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs
-.mli.cmi:
+.ml.cmo:
$(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-.ml.cmo:
+.mli.cmi:
$(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
.ml.cmx:
$(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
-odoc_text_parser.ml odoc_text_parser.mli: odoc_text_parser.mly
- $(OCAMLYACC) odoc_text_parser.mly
+.ml.cmxs:
+ $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $<
-odoc_parser.ml odoc_parser.mli: odoc_parser.mly
- $(OCAMLYACC) odoc_parser.mly
+.mll.ml:
+ $(OCAMLLEX) $<
-odoc_text_lexer.ml: odoc_text_lexer.mll
- $(OCAMLLEX) odoc_text_lexer.mll
+.mly.ml:
+ $(OCAMLYACC) -v $<
-odoc_lexer.ml: odoc_lexer.mll
- $(OCAMLLEX) odoc_lexer.mll
-
-odoc_ocamlhtml.ml: odoc_ocamlhtml.mll
- $(OCAMLLEX) odoc_ocamlhtml.mll
-
-odoc_see_lexer.ml: odoc_see_lexer.mll
- $(OCAMLLEX) odoc_see_lexer.mll
+.mly.mli:
+ $(OCAMLYACC) -v $<
# Installation targets
######################
install: dummy
$(MKDIR) -p $(INSTALL_BINDIR)
$(MKDIR) -p $(INSTALL_LIBDIR)
- $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC).exe
+ $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)
$(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR)
$(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
installopt_really:
$(MKDIR) -p $(INSTALL_BINDIR)
$(MKDIR) -p $(INSTALL_LIBDIR)
- $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT).exe
+ $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE)
$(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) $(INSTALL_LIBDIR)
$(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
@rm -f odoc_parser.output odoc_text_parser.output
@rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
@rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
+ @rm -rf stdlib_man
+ @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as]
depend::
- rm -f .depend
$(OCAMLYACC) odoc_text_parser.mly
$(OCAMLYACC) odoc_parser.mly
$(OCAMLLEX) odoc_text_lexer.mll
$(OCAMLLEX) odoc_lexer.mll
+ $(OCAMLLEX) odoc_ocamlhtml.mll
+ $(OCAMLLEX) odoc_see_lexer.mll
$(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
dummy:
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id$ *)
-
open Odoc_info
module Naming = Odoc_html.Naming
open Odoc_info.Value
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id$ *)
-
(** An OCamldoc generator to retrieve information in "todo" tags and
generate an html page with all todo items. *)
%(***********************************************************************)
+%(* *)
%(* OCamldoc *)
%(* *)
%(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc.ml 10653 2010-08-24 11:48:46Z guesdon $ *)
-
(** Main module for bytecode.
@todo coucou le todo*)
let rec iter (files, incs) = function
[] | _ :: [] -> (List.rev files, List.rev incs)
| "-g" :: file :: q when
- ((Filename.check_suffix file "cmo") or
- (Filename.check_suffix file "cma") or
+ ((Filename.check_suffix file "cmo") ||
+ (Filename.check_suffix file "cma") ||
(Filename.check_suffix file "cmxs")) ->
iter (file :: files, incs) q
| "-i" :: dir :: q ->
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_analyse.ml 12862 2012-08-16 09:44:48Z guesdon $ *)
-
(** Analysis of source files. This module is strongly inspired from
driver/main.ml :-) *)
(** Optionally preprocess a source file *)
let preprocess sourcefile =
- match !Clflags.preprocessor with
- None -> sourcefile
- | Some pp ->
- let tmpfile = Filename.temp_file "ocamldocpp" "" in
- let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
- if Ccomp.command comm <> 0 then begin
- remove_file tmpfile;
- Printf.eprintf "Preprocessing error\n";
- exit 2
- end;
- tmpfile
-
-(** Remove the input file if this file was the result of a preprocessing.*)
-let remove_preprocessed inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ -> remove_file inputfile
-
-let remove_preprocessed_if_ast inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ -> if inputfile <> !Location.input_name then remove_file inputfile
-
-exception Outdated_version
-
-(** Parse a file or get a dumped syntax tree in it *)
-let parse_file inputfile parse_fun ast_magic =
- let ic = open_in_bin inputfile in
- let is_ast_file =
- try
- let buffer = Misc.input_bytes ic (String.length ast_magic) in
- if buffer = ast_magic then true
- else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
- raise Outdated_version
- else false
- with
- Outdated_version ->
- fatal_error "OCaml and preprocessor have incompatible versions"
- | _ -> false
- in
- let ast =
- try
- if is_ast_file then begin
- Location.input_name := input_value ic;
- input_value ic
- end else begin
- seek_in ic 0;
- Location.input_name := inputfile;
- let lexbuf = Lexing.from_channel ic in
- Location.init lexbuf inputfile;
- parse_fun lexbuf
- end
- with x -> close_in ic; raise x
- in
- close_in ic;
- ast
+ try
+ Pparse.preprocess sourcefile
+ with Pparse.Error err ->
+ Format.eprintf "Preprocessing error@.%a@."
+ Pparse.report_error err;
+ exit 2
let (++) x f = f x
let inputfile = preprocess sourcefile in
let env = initial_env () in
try
- let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in
+ let parsetree = Pparse.file Format.err_formatter inputfile Parse.implementation ast_impl_magic_number in
let typedtree =
Typemod.type_implementation
sourcefile prefixname modulename env parsetree
let modulename = String.capitalize(Filename.basename prefixname) in
Env.set_unit_name modulename;
let inputfile = preprocess sourcefile in
- let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
+ let ast = Pparse.file Format.err_formatter inputfile Parse.interface ast_intf_magic_number in
let sg = Typemod.transl_signature (initial_env()) ast in
Warnings.check_fatal ();
(ast, sg, inputfile)
fprintf ppf
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value." l l'
- | Typecore.Error(loc, err) ->
- Location.print_error ppf loc; Typecore.report_error ppf err
- | Typetexp.Error(loc, err) ->
- Location.print_error ppf loc; Typetexp.report_error ppf err
+ | Typecore.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typecore.report_error env ppf err
+ | Typetexp.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typetexp.report_error env ppf err
| Typedecl.Error(loc, err) ->
Location.print_error ppf loc; Typedecl.report_error ppf err
| Includemod.Error err ->
Location.print_error_cur_file ppf;
Includemod.report_error ppf err
- | Typemod.Error(loc, err) ->
- Location.print_error ppf loc; Typemod.report_error ppf err
+ | Typemod.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typemod.report_error env ppf err
| Translcore.Error(loc, err) ->
Location.print_error ppf loc; Translcore.report_error ppf err
| Sys_error msg ->
Location.print_error_cur_file ppf;
fprintf ppf "I/O error: %s" msg
- | Typeclass.Error(loc, err) ->
- Location.print_error ppf loc; Typeclass.report_error ppf err
+ | Typeclass.Error(loc, env, err) ->
+ Location.print_error ppf loc; Typeclass.report_error env ppf err
| Translclass.Error(loc, err) ->
Location.print_error ppf loc; Translclass.report_error ppf err
| Warnings.Errors (n) ->
Location.print_error_cur_file ppf;
- fprintf ppf "Error-enabled warnings (%d occurrences)" n
+ fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
| x ->
fprintf ppf "@]";
fprintf ppf
print_string Odoc_messages.ok;
print_newline ()
);
- remove_preprocessed input_file;
+ Pparse.remove_preprocessed input_file;
Some file_module
with
| Sys_error s
print_string Odoc_messages.ok;
print_newline ()
);
- remove_preprocessed input_file;
+ Pparse.remove_preprocessed input_file;
Some file_module
with
| Sys_error s
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_analyse.mli 10652 2010-08-24 09:45:45Z guesdon $ *)
-
(** Analysis of source files. *)
(** This function builds the top modules from the analysis of the
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* cvsid $Id: odoc_args.ml 12221 2012-03-12 17:57:46Z guesdon $ *)
-
(** Command-line arguments. *)
module M = Odoc_messages
(Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs),
M.include_dirs ;
"-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ;
+ "-ppx", Arg.String (fun s -> Odoc_global.ppx := s :: !Odoc_global.ppx), M.ppx ;
"-impl", Arg.String (fun s ->
Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]),
M.option_impl ;
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_args.mli 12221 2012-03-12 17:57:46Z guesdon $ *)
-
(** Analysis of the command line arguments. *)
(** The current module defining the generator to use. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_ast.ml 12951 2012-09-25 07:14:43Z guesdon $ *)
-
(** Analysis of implementation files. *)
open Misc
open Asttypes
(List.map iter_pattern patlist,
Odoc_env.subst_type env pat.pat_type)
- | Typedtree.Tpat_construct (_, _, cons_desc, _, _) when
+ | Typedtree.Tpat_construct (_, cons_desc, _, _) when
(* we give a name to the parameter only if it unit *)
(match cons_desc.cstr_res.desc with
Tconstr (p, _, _) ->
| ((Parsetree.Pcf_val ({ txt = label }, mutable_flag, _, _) |
Parsetree.Pcf_valvirt ({ txt = label }, mutable_flag, _) ) as x) ->
- let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let type_exp =
- try Typedtree_search.search_attribute_type tt_cls label
- with Not_found ->
+ let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in
+ let complete_name = Name.concat current_class_name label in
+ let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+ let type_exp =
+ try Typedtree_search.search_attribute_type tt_cls label
+ with Not_found ->
raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
in
let code =
iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
| (Parsetree.Pcf_virt ({ txt = label }, private_flag, _)) ->
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let met_type =
- try Odoc_sig.Signature_search.search_method_type label tt_class_sig
- with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
- in
- let real_type =
+ let complete_name = Name.concat current_class_name label in
+ let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+ let met_type =
+ try Odoc_sig.Signature_search.search_method_type label tt_class_sig
+ with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
+ in
+ let real_type =
match met_type.Types.desc with
Tarrow (_, _, t, _) ->
t
iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
| (Parsetree.Pcf_meth ({ txt = label }, private_flag, _, _)) ->
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let exp =
+ let complete_name = Name.concat current_class_name label in
+ let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+ let exp =
try Typedtree_search.search_method_expression tt_cls label
with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
in
let new_env = Odoc_env.add_value env new_value.val_name in
(0, new_env, [Element_value new_value])
- | Parsetree.Pstr_type name_typedecl_list ->
- (* of (string * type_declaration) list *)
- (* we start by extending the environment *)
- let new_env =
- List.fold_left
+ | Parsetree.Pstr_type name_typedecl_list ->
+ (* of (string * type_declaration) list *)
+ (* we start by extending the environment *)
+ let new_env =
+ List.fold_left
(fun acc_env -> fun ({ txt = name }, _) ->
- let complete_name = Name.concat current_module_name name in
- Odoc_env.add_type acc_env complete_name
+ let complete_name = Name.concat current_module_name name in
+ Odoc_env.add_type acc_env complete_name
)
env
name_typedecl_list
- in
- let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list =
- match name_type_decl_list with
- [] -> (maybe_more_acc, [])
- | ({ txt = name }, type_decl) :: q ->
- let complete_name = Name.concat current_module_name name in
- let loc = type_decl.Parsetree.ptype_loc in
- let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
- let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
+ in
+ let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list =
+ match name_type_decl_list with
+ [] -> (maybe_more_acc, [])
+ | ({ txt = name }, type_decl) :: q ->
+ let complete_name = Name.concat current_module_name name in
+ let loc = type_decl.Parsetree.ptype_loc in
+ let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
+ let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+ let pos_limit2 =
match q with
[] -> pos_limit
| (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
ty_info = com_opt ;
ty_parameters =
List.map2
- (fun p (co,cn,_) ->
- (Odoc_env.subst_type new_env p,
- co, cn)
- )
- tt_type_decl.Types.type_params
- tt_type_decl.Types.type_variance ;
+ (fun p v ->
+ let (co, cn) = Types.Variance.get_upper v in
+ (Odoc_env.subst_type new_env p, co, cn))
+ tt_type_decl.Types.type_params
+ tt_type_decl.Types.type_variance ;
ty_kind = kind ;
ty_private = tt_type_decl.Types.type_private;
ty_manifest =
in
(0, new_env2, [ Element_module_type mt ])
- | Parsetree.Pstr_open longident ->
+ | Parsetree.Pstr_open (_, longident) ->
(* A VOIR : enrichir l'environnement quand open ? *)
let ele_comments = match comment_opt with
None -> []
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_ast.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(** The module for analysing the typed abstract syntax tree and source code and creating modules, classes, ..., elements.*)
type typedtree = Typedtree.structure * Typedtree.module_coercion
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_class.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
(** Representation and manipulation of classes and class types.*)
module Name = Odoc_name
with
Not_found ->
None
-
-
-(* eof $Id: odoc_class.ml 12796 2012-07-30 11:22:29Z doligez $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_comments.ml 12245 2012-03-14 21:01:41Z guesdon $ *)
-
(** Analysis of comments. *)
open Odoc_types
with
Failure s ->
incr Odoc_global.errors ;
- prerr_endline (file^" : "^s^"\n");
+ Printf.eprintf "File %S, line %d:\n%s\n%!" file (!Odoc_lexer.line_number + 1) s;
(0, None)
| Odoc_text.Text_syntax (l, c, s) ->
incr Odoc_global.errors ;
| (len, Some d) ->
(* we check if the comment we got was really attached to the constructor,
i.e. that there was no blank line or any special comment "(**" before *)
- if (not strict) or (nothing_before_simple_comment s) then
+ if (not strict) || (nothing_before_simple_comment s) then
(* ok, we attach the comment to the constructor *)
(len, Some d)
else
(* if the special comment is the stop comment (**/**),
then we must not associate it. *)
let pos = Str.search_forward (Str.regexp_string "(**") s 0 in
- if blank_line (String.sub s 0 pos) or
+ if blank_line (String.sub s 0 pos) ||
d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"]
then
(0, None)
| h :: q ->
if (blank_line_outside_simple file
(String.sub s len ((String.length s) - len)) )
- or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"]
+ || h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"]
then
(None, special_coms)
else
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_comments.mli 7619 2006-09-20 11:14:37Z doligez $ *)
-
(** Analysis of comments. *)
val simple_blank : string
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_comments_global.ml 10480 2010-05-31 11:52:13Z guesdon $ *)
-
(** The global variables used by the special comment parser.*)
let nb_chars = ref 0
raised_exceptions := [];
return_value := None ;
customs := []
-
-(* eof $Id: odoc_comments_global.ml 10480 2010-05-31 11:52:13Z guesdon $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_comments_global.mli 10480 2010-05-31 11:52:13Z guesdon $ *)
-
(** The global variables used by the special comment parser.*)
(** the number of chars used in the lexer. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_config.ml 8416 2007-10-08 14:19:34Z doligez $ *)
-
let custom_generators_path =
Filename.concat Config.standard_library
(Filename.concat "ocamldoc" "custom")
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_config.mli 8416 2007-10-08 14:19:34Z doligez $ *)
-
(** Ocamldoc configuration contants. *)
(** Default path to search for custom generators and to install them. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
-
-(* $Id: odoc_control.ml 9547 2010-01-22 12:48:24Z doligez $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_cross.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
(** Cross referencing. *)
module Name = Odoc_name
module Map_ord =
struct
type t = string
- let compare = Pervasives.compare
+ let compare (x:t) y = Pervasives.compare x y
end
module Ele_map = Map.Make (Map_ord)
None -> (acc_b, (Name.head m.m_name) :: acc_inc,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
- (if ma.ma_name = Odoc_messages.struct_end or
+ (if ma.ma_name = Odoc_messages.struct_end ||
ma.ma_name = Odoc_messages.sig_end then
acc_names
else
None -> (acc_b, (Name.head m.m_name) :: acc_inc,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
- (if mta.mta_name = Odoc_messages.struct_end or
+ (if mta.mta_name = Odoc_messages.struct_end ||
mta.mta_name = Odoc_messages.sig_end then
acc_names
else
None -> (acc_b, (Name.head mt.mt_name) :: acc_inc,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
- (if mta.mta_name = Odoc_messages.struct_end or
+ (if mta.mta_name = Odoc_messages.struct_end ||
mta.mta_name = Odoc_messages.sig_end then
acc_names
else
None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
- (if im.im_name = Odoc_messages.struct_end or
+ (if im.im_name = Odoc_messages.struct_end ||
im.im_name = Odoc_messages.sig_end then
acc_names_not_found
else
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_cross.mli 7619 2006-09-20 11:14:37Z doligez $ *)
-
(** Cross-referencing. *)
val associate : Odoc_module.t_module list -> unit
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_dag2html.ml 6723 2004-12-03 14:42:09Z guesdon $ *)
-
(** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *)
type 'a dag = { mutable dag : 'a node array }
;;
let group_by_common_children d list =
- let module O = struct type t = idag;; let compare = compare;; end
+ let module O = struct type t = idag;; let compare (x:t) y = compare x y;; end
in
let module S = Set.Make (O)
in
if A and B have common children *)
let group_span_by_common_children d t =
- let module O = struct type t = idag;; let compare = compare;; end
+ let module O = struct type t = idag;; let compare (x:t) y = compare x y;; end
in
let module S = Set.Make (O)
in
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_dag2html.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** The types and functions to create a html table representing a dag.
Thanks to Daniel de Rauglaudre. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_dep.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Top modules dependencies. *)
module StrS = Depend.StringSet
struct
type id = string
- module S = Set.Make (struct type t = string let compare = compare end)
+ module S = Set.Make (struct
+ type t = string
+ let compare (x:t) y = compare x y
+ end)
let set_to_list s =
let l = ref [] in
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_dot.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Definition of a class which outputs a dot file showing
top modules dependencies.*)
method generate_for_module fmt m =
let l = List.filter
(fun n ->
- !dot_include_all or
+ !dot_include_all ||
(List.exists (fun m -> m.Module.m_name = n) modules))
m.Module.m_top_deps
in
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_env.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
(** Environment for finding complete names from relative names. *)
let print_DEBUG s = print_string s ; print_newline ();;
Types.Cty_fun (l, new_texp, new_ct)
in
iter t
-
-(* eof $Id: odoc_env.ml 12796 2012-07-30 11:22:29Z doligez $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_env.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** Environment for finding complete names from relative names. *)
(** An environment of known names,
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_exception.ml 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** Representation and manipulation of exceptions. *)
module Name = Odoc_name
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Gallium, INRIA Rocquencourt *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_global.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Global variables. *)
(* Tell ocaml compiler not to generate files. *)
(** Optional preprocessor command. *)
let preprocessor = Clflags.preprocessor
+let ppx = Clflags.all_ppx
let sort_modules = ref false
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_global.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Global variables. *)
(** The kind of source file in arguments. *)
val include_dirs : string list ref
(** Optional preprocessor command to pass to ocaml compiler. *)
-val preprocessor : string option ref
+val preprocessor : string option ref (* -pp *)
+val ppx : string list ref (* -ppx *)
(** Recursive types flag to passe to ocaml compiler. *)
val recursive_types : bool ref
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_html.ml 12953 2012-09-25 07:50:40Z guesdon $ *)
-
(** Generation of html documentation.*)
let print_DEBUG s = print_string s ; print_newline ()
f
end
-module StringSet = Set.Make (struct type t = string let compare = compare end)
+module StringSet = Set.Make (struct
+ type t = string
+ let compare (x:t) y = compare x y
+end)
(** A class with a method to colorize a string which represents OCaml code. *)
class ocaml_code =
@param indent can be specified not to use the style of info comments;
default is [true].
*)
- method html_of_info ?(indent=true) b info_opt =
+ method html_of_info ?(cls="") ?(indent=true) b info_opt =
match info_opt with
None ->
()
| Some info ->
let module M = Odoc_info in
- if indent then bs b "<div class=\"info\">\n";
+ if indent then bs b ("<div class=\"info "^cls^"\">\n");
(
match info.M.i_deprecated with
None -> ()
(** Print html code for a value. *)
method html_of_value b v =
Odoc_info.reset_type_names ();
- bs b "<pre>" ;
bp b "<span id=\"%s\">" (Naming.value_target v);
bs b (self#keyword "val");
bs b " ";
(** Print html code for an exception. *)
method html_of_exception b e =
Odoc_info.reset_type_names ();
- bs b "<pre>";
bp b "<span id=\"%s\">" (Naming.exception_target e);
bs b (self#keyword "exception");
bs b " ";
let father = Name.father t.ty_name in
bs b
(match t.ty_manifest, t.ty_kind with
- None, Type_abstract -> "<pre>"
+ None, Type_abstract -> "
\n<pre>"
| None, Type_variant _
- | None, Type_record _ -> "<pre><code>"
- | Some _, Type_abstract -> "<pre>"
+ | None, Type_record _ -> "
\n<pre><code>"
+ | Some _, Type_abstract -> "
\n<pre>"
| Some _, Type_variant _
- | Some _, Type_record _ -> "<pre>"
+ | Some _, Type_record _ -> "
\n<pre>"
);
bp b "<span id=\"%s\">" (Naming.type_target t);
bs b ((self#keyword "type")^" ");
bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
bs b "<code>";
if r.rf_mutable then bs b (self#keyword "mutable ") ;
- bp b "<span id=\"%s\">%s</span> :"
+ bp b "<span id=\"%s\">%s</span> : "
(Naming.recfield_target t r)
r.rf_name;
self#html_of_type_expr b father r.rf_type;
(** Print html code for a class attribute. *)
method html_of_attribute b a =
let module_name = Name.father (Name.father a.att_value.val_name) in
- bs b "<pre>" ;
bp b "<span id=\"%s\">" (Naming.attribute_target a);
bs b (self#keyword "val");
bs b " ";
(** Print html code for a class method. *)
method html_of_method b m =
let module_name = Name.father (Name.father m.met_value.val_name) in
- bs b "<pre>";
(* html mark *)
bp b "<span id=\"%s\">" (Naming.method_target m);
bs b ((self#keyword "method")^" ");
method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m =
let (html_file, _) = Naming.html_files m.m_name in
let father = Name.father m.m_name in
- bs b "<pre>";
bs b ((self#keyword "module")^" ");
(
if with_link then
if info then
(
if complete then
- self#html_of_info ~indent: true
+ self#html_of_info ~cls: "module top" ~indent: true
else
self#html_of_info_first_sentence
) b m.m_info
method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt =
let (html_file, _) = Naming.html_files mt.mt_name in
let father = Name.father mt.mt_name in
- bs b "<pre>";
bs b ((self#keyword "module type")^" ");
(
if with_link then
if info then
(
if complete then
- self#html_of_info ~indent: true
+ self#html_of_info ~cls: "modtype top" ~indent: true
else
self#html_of_info_first_sentence
) b mt.mt_info
(** Print html code for an included module. *)
method html_of_included_module b im =
- bs b "<pre>";
bs b ((self#keyword "include")^" ");
(
match im.im_module with
let father = Name.father c.cl_name in
Odoc_info.reset_type_names ();
let (html_file, _) = Naming.html_files c.cl_name in
- bs b "<pre>";
(* we add a html id, the same as for a type so we can
go directly here when the class name is used as a type name *)
bp b "<span name=\"%s\">"
print_DEBUG "html#html_of_class : info" ;
(
if complete then
- self#html_of_info ~indent: true
+ self#html_of_info ~cls: "class top" ~indent: true
else
self#html_of_info_first_sentence
) b c.cl_info
Odoc_info.reset_type_names ();
let father = Name.father ct.clt_name in
let (html_file, _) = Naming.html_files ct.clt_name in
- bs b "<pre>";
(* we add a html id, the same as for a type so we can
go directly here when the class type name is used as a type name *)
bp b "<span id=\"%s\">"
bs b "</pre>";
(
if complete then
- self#html_of_info ~indent: true
+ self#html_of_info ~cls: "classtype top" ~indent: true
else
self#html_of_info_first_sentence
) b ct.clt_info
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_info.ml 12435 2012-05-07 10:31:18Z guesdon $ *)
-
(** Interface for analysing documented OCaml source files and to the collected information. *)
type ref_kind = Odoc_types.ref_kind =
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_info.mli 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Interface to the information collected in source files. *)
(** The differents kinds of element references. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
-
-(* $Id: odoc_inherit.ml 9547 2010-01-22 12:48:24Z doligez $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_latex.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Generation of LaTeX documentation. *)
let print_DEBUG s = print_string s ; print_newline ()
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(** The content of the LaTeX style to generate when generating LaTeX code. *)
-(* $Id: odoc_latex_style.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
let content ="\
\n%% Support macros for LaTeX documentation generated by ocamldoc.\
\n%% This file is in the public domain; do what you want with it.\
(* *)
(***********************************************************************)
-(* $Id: odoc_lexer.mll 12796 2012-07-30 11:22:29Z doligez $ *)
-
(** The lexer for special comments. *)
open Lexing
incr Odoc_comments_global.nb_chars;
print_DEBUG2 "newline";
elements lexbuf }
+ | "@"
+ {
+ raise (Failure (Odoc_messages.should_escape_at_sign))
+ }
| "@"lowercase+
{
{
EOF
}
+ | _ {
+ let s = Lexing.lexeme lexbuf in
+ failwith ("Unexpected character '"^s^"'")
+ }
and simple = parse
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_man.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** The man pages generator. *)
open Odoc_info
open Parameter
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_merge.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
(** Merge of information from [.ml] and [.mli] for a module.*)
open Odoc_types
raise (Failure (Odoc_messages.two_interfaces m.m_name))
)
| _ ->
- (* two many Module.t ! *)
+ (* too many Module.t ! *)
raise (Failure (Odoc_messages.too_many_module_objects m.m_name))
in
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_merge.mli 12796 2012-07-30 11:22:29Z doligez $ *)
-
(** Merge of information from [.ml] and [.mli] for a module.*)
(** Merging \@before tags. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_messages.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
(** The messages of the application. *)
let ok = "Ok"
let include_dirs = "<dir>\tAdd <dir> to the list of include directories"
let rectypes = "\tAllow arbitrary recursive types"
let preprocess = "<command>\tPipe sources through preprocessor <command>"
+let ppx = "<command>\n\t\tPipe abstract syntax tree through preprocessor <command>"
let option_impl ="<file>\tConsider <file> as a .ml file"
let option_intf ="<file>\tConsider <file> as a .mli file"
let option_text ="<file>\tConsider <file> as a .txt file"
(String.concat "\n" paths)
let tag_not_handled tag = "Tag @"^tag^" not handled by this generator"
+let should_escape_at_sign = "The character @ has a special meaning in ocamldoc comments, for commands such as @raise or @since. If you want to write a single @, you must escape it as \\@."
let bad_tree = "Incorrect tree structure."
let not_a_valid_tag s = s^" is not a valid tag."
let fun_without_param f = "Function "^f^" has no parameter.";;
let unknown_extension f = "Unknown extension for file "^f^"."
let two_implementations name = "There are two implementations of module "^name^"."
let two_interfaces name = "There are two interfaces of module "^name^"."
-let too_many_module_objects name = "There are two many interfaces/implementation of module "^name^"."
+let too_many_module_objects name = "There are too many interfaces/implementation of module "^name^"."
let exception_not_found_in_implementation exc m = "Exception "^exc^" was not found in implementation of module "^m^"."
let type_not_found_in_implementation exc m = "Type "^exc^" was not found in implementation of module "^m^"."
let module_not_found_in_implementation m m2 = "Module "^m^" was not found in implementation of module "^m2^"."
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_misc.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
let no_blanks s =
let len = String.length s in
let buf = Buffer.create len in
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_misc.mli 7307 2006-01-04 16:55:50Z doligez $ *)
-
-(** Miscelaneous functions *)
+(** Miscellaneous functions *)
(** [no_blanks s] returns the given string without any blank
characters, i.e. '\n' '\r' ' ' '\t'.
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_module.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(** Representation and manipulation of modules and module types. *)
let print_DEBUG s = print_string s ; print_newline ()
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_name.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Representation of element names. *)
let infix_chars = [ '|' ;
_ -> 1
let prefix n1 n2 =
- (n1 <> n2) &
+ (n1 <> n2) &&
(try
let len1 = String.length n1 in
- ((String.sub n2 0 len1) = n1) &
+ ((String.sub n2 0 len1) = n1) &&
(n2.[len1] = '.')
with _ -> false)
let (f1,s1) = head_and_tail n1 in
let (f2,s2) = head_and_tail n2 in
if f1 = f2 then
- if f2 = s2 or s2 = "" then
+ if f2 = s2 || s2 = "" then
s2
else
- if f1 = s1 or s1 = "" then
+ if f1 = s1 || s1 = "" then
s2
else
get_relative_raw s1 s2
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_name.mli 12622 2012-06-21 05:46:28Z guesdon $ *)
-
(** Representation of element names. *)
type t = string
(* *)
(***********************************************************************)
-(* $Id: odoc_ocamlhtml.mll 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** Generation of html code to display OCaml code. *)
open Lexing
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_parameter.ml 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** Representation and manipulation of method / function / class parameters. *)
let print_DEBUG s = print_string s ; print_newline ()
(* *)
(***********************************************************************)
-(* $Id: odoc_parser.mly 10480 2010-05-31 11:52:13Z guesdon $ *)
-
open Odoc_types
open Odoc_comments_global
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_print.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
open Format
let new_fmt () =
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_print.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** Printing functions. *)
(** This function takes a Types.type_expr and returns a string.
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_scan.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
(** Scanning of modules and elements.
The class scanner defined in this module can be used to
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_search.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
(** Research of elements through modules. *)
module Name = Odoc_name
with
Res_section (_,t) -> t
| _ -> assert false
-
-(* eof $Id: odoc_search.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_search.mli 12249 2012-03-20 12:00:11Z guesdon $ *)
-
(** Research of elements through modules. *)
(** The type for an element of the result of a research. *)
(* *)
(***********************************************************************)
-(* $Id: odoc_see_lexer.mll 9547 2010-01-22 12:48:24Z doligez $ *)
-
let print_DEBUG2 s = print_string s ; print_newline ()
(** the lexer for special comments. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_sig.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Analysis of interface files. *)
open Misc
ty_name = Name.concat current_module_name name.txt ;
ty_info = assoc_com ;
ty_parameters =
- List.map2 (fun p (co,cn,_) ->
- (Odoc_env.subst_type new_env p,
- co, cn)
- )
+ List.map2 (fun p v ->
+ let (co, cn) = Types.Variance.get_upper v in
+ (Odoc_env.subst_type new_env p,co, cn))
sig_type_decl.Types.type_params
sig_type_decl.Types.type_variance;
ty_kind = type_kind;
im_info = comment_opt;
}
in
- (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
+ (0, env, [ Element_included_module im ]) (* A VOIR : etendre l'environnement ? avec quoi ? *)
| Parsetree.Psig_class class_description_list ->
(* we start by extending the environment *)
)
else
(
- raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents")
+ raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels differents")
)
| _ ->
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_sig.mli 12622 2012-06-21 05:46:28Z guesdon $ *)
-
(** The module for analysing a signature and source code and creating modules, classes, ..., elements.*)
(** The functions used to retrieve information from a signature. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_str.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
module Name = Odoc_name
(match m.M.met_value.M.val_info with
None -> ""
| Some i -> Odoc_misc.string_of_info i)
-
-(* eof $Id: odoc_str.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_str.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
(** @return the variance string for the given type and (covariant, contravariant) information. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_test.ml 12221 2012-03-12 17:57:46Z guesdon $ *)
-
(** Custom generator to perform test on ocamldoc. *)
open Odoc_info
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Olivier Andrieu, base sur du code de Maxence Guesdon *)
(* *)
(***********************************************************************)
-(* $Id: odoc_texi.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
(** Generation of Texinfo documentation. *)
open Odoc_info
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_text.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
exception Text_syntax of int * int * string (* line, char, string *)
open Odoc_types
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_text.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
(** A module with a function to parse strings to obtain a [Odoc_types.text] value. *)
(** Syntax error in a text. *)
(* *)
(***********************************************************************)
-(* $Id: odoc_text_lexer.mll 12796 2012-07-30 11:22:29Z doligez $ *)
-
(** The lexer for string to build text structures. *)
open Lexing
{
print_DEBUG "end";
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
+ if !verb_mode || !target_mode || !code_pre_mode ||
(!open_brackets >= 1) then
Char (Lexing.lexeme lexbuf)
else
{
print_DEBUG "begin_title";
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
let s = Lexing.lexeme lexbuf in
| begin_bold
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
BOLD
| begin_italic
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
ITALIC
| begin_link
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
LINK
| begin_emp
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
EMP
| begin_superscript
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
SUPERSCRIPT
| begin_subscript
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
SUBSCRIPT
| begin_center
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
CENTER
| begin_left
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
LEFT
| begin_right
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode
- or (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode
+ || (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
RIGHT
{
print_DEBUG "LIST";
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
LIST
| begin_enum
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
ENUM
{
print_DEBUG "ITEM";
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
ITEM
| begin_target
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
(
| begin_latex
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
(
| end_target
{
incr_cpts lexbuf ;
- if !verb_mode or (!open_brackets >= 1) or !code_pre_mode or
+ if !verb_mode || (!open_brackets >= 1) || !code_pre_mode ||
!ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
| begin_code
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
if !open_brackets <= 0 then
| end_code
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
if !open_brackets > 1 then
| begin_code_pre
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
(
| end_code_pre
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !ele_ref_mode then
+ if !verb_mode || !target_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
if !open_brackets >= 1 then
| begin_ele_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_val_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_typ_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_exc_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_mod_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_modt_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_cla_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_clt_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_att_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_met_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_sec_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_recf_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_const_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_mod_list_ref
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| index_list
{
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+ if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
else
if not !ele_ref_mode then
| begin_verb
{
incr_cpts lexbuf ;
- if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
+ if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
(
| end_verb
{
incr_cpts lexbuf ;
- if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
+ if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
(
END_SHORTCUT_LIST
)
else
- if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then
+ if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode || !verb_mode then
Char (Lexing.lexeme lexbuf)
else
BLANK_LINE
{
print_DEBUG "begin_custom";
incr_cpts lexbuf ;
- if !verb_mode or !target_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
+ if !verb_mode || !target_mode || !code_pre_mode ||
+ (!open_brackets >= 1) || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
let s = Lexing.lexeme lexbuf in
| "{"
{
incr_cpts lexbuf ;
- if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
+ if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
LBRACE
(* *)
(***********************************************************************)
-(* $Id: odoc_text_parser.mly 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Odoc_types
let identchar =
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_to_text.ml 10480 2010-05-31 11:52:13Z guesdon $ *)
-
(** Text generation.
This module contains the class [to_text] with methods used to transform
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_type.ml 11160 2011-07-29 10:32:43Z garrigue $ *)
-
(** Representation and manipulation of a type, but not class nor module type.*)
module Name = Odoc_name
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_types.ml 12435 2012-05-07 10:31:18Z guesdon $ *)
-
type ref_kind =
RK_module
| RK_module_type
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_types.mli 12435 2012-05-07 10:31:18Z guesdon $ *)
-
(** Types for the information collected in comments. *)
(** The differents kinds of element references. *)
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_value.ml 11210 2011-09-22 09:05:42Z garrigue $ *)
-
(** Representation and manipulation of values, class attributes and class methods. *)
module Name = Odoc_name
#(* *)
#(***********************************************************************)
-# $Id: remove_DEBUG 11156 2011-07-27 14:17:02Z doligez $
-
# usage: remove_DEBUG <file>
# remove from <file> every line that contains the string "DEBUG",
# respecting the cpp # line annotation conventions
# #
#######################################################################
-# $Id: runocamldoc 11156 2011-07-27 14:17:02Z doligez $
-
case "$1" in
true) shift
exec ../boot/ocamlrun -I ../otherlibs/unix -I ../otherlibs/str \
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
# Common Makefile for otherlibs on the Unix ports
CAMLC=$(ROOTDIR)/ocamlcomp.sh
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
# Common Makefile for otherlibs on the Win32/MinGW ports
CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -w s
# #
#########################################################################
-# $Id: Makefile.shared 11156 2011-07-27 14:17:02Z doligez $
-
# Common Makefile for otherlibs
ROOTDIR=../..
# Compilation options
CC=$(BYTECC)
CAMLRUN=$(ROOTDIR)/boot/ocamlrun
-COMPFLAGS=-warn-error A -g $(EXTRACAMLFLAGS)
+COMPFLAGS=-w +33..39 -warn-error A -g $(EXTRACAMLFLAGS)
MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
# Variables to be defined by individual libraries:
allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
$(LIBNAME).cma: $(CAMLOBJS)
- $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall $(CAMLOBJS) $(LINKOPTS)
+ $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
+ $(CAMLOBJS) $(LINKOPTS)
$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
- $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall $(CAMLOBJS_NAT) $(LINKOPTS)
+ $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
+ $(CAMLOBJS_NAT) $(LINKOPTS)
$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \
../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \
../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h
+ ../../byterun/minor_gc.h ../../byterun/int64_native.h
mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \
../../byterun/../config/m.h ../../byterun/../config/s.h \
../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
LIBNAME=bigarray
EXTRACFLAGS=-I../unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
EXTRACAMLFLAGS=-I ../unix
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
LIBNAME=bigarray
EXTRACFLAGS=-I../win32unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
EXTRACAMLFLAGS=-I ../win32unix
/* */
/***********************************************************************/
-/* $Id: bigarray.h 12311 2012-04-03 13:49:17Z xleroy $ */
-
#ifndef CAML_BIGARRAY_H
#define CAML_BIGARRAY_H
#endif
};
+/* Size of struct caml_ba_array, in bytes, without dummy first dimension */
+#if (__STDC_VERSION__ >= 199901L)
+#define SIZEOF_BA_ARRAY sizeof(struct caml_ba_array)
+#else
+#define SIZEOF_BA_ARRAY (sizeof(struct caml_ba_array) - sizeof(intnat))
+#endif
+
#define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v))
#define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data)
(* *)
(***********************************************************************)
-(* $Id: bigarray.ml 12433 2012-05-06 08:23:37Z xleroy $ *)
-
(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
external init : unit -> unit = "caml_ba_init"
external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
bool -> int array -> int64 -> ('a, 'b, 'c) t
- = "caml_ba_map_file_bytecode" "caml_ba_map_file"
+ = "caml_ba_map_file_bytecode" "caml_ba_map_file"
let map_file fd ?(pos = 0L) kind layout shared dims =
map_internal fd kind layout shared dims pos
end
external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
- external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1"
- let dim a = Genarray.nth_dim a 0
+ external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_1"
+ external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub"
Genarray.create kind layout [|dim1; dim2|]
external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
- external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2"
- external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_2"
- let dim1 a = Genarray.nth_dim a 0
- let dim2 a = Genarray.nth_dim a 1
+ external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
+ = "%caml_ba_unsafe_ref_2"
+ external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_2"
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
+ = "caml_ba_sub"
external sub_right:
('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
+ = "caml_ba_sub"
let slice_left a n = Genarray.slice_left a [|n|]
let slice_right a n = Genarray.slice_right a [|n|]
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
Genarray.create kind layout [|dim1; dim2; dim3|]
external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
- = "%caml_ba_set_3"
- external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3"
- external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_3"
- let dim1 a = Genarray.nth_dim a 0
- let dim2 a = Genarray.nth_dim a 1
- let dim3 a = Genarray.nth_dim a 2
+ = "%caml_ba_set_3"
+ external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
+ = "%caml_ba_unsafe_ref_3"
+ external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_3"
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+ external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
+ = "caml_ba_sub"
external sub_right:
- ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
+ ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
let slice_left_1 a n m = Genarray.slice_left a [|n; m|]
let slice_right_1 a n m = Genarray.slice_right a [|n; m|]
let slice_left_2 a n = Genarray.slice_left a [|n|]
end
external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
+ = "%identity"
external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
+ = "%identity"
external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
+ = "%identity"
let array1_of_genarray a =
if Genarray.num_dims a = 1 then a
else invalid_arg "Bigarray.array1_of_genarray"
(* *)
(***********************************************************************)
-(* $Id: bigarray.mli 12772 2012-07-24 22:43:01Z doligez $ *)
-
(** Large, multi-dimensional, numerical arrays.
This module implements multi-dimensional arrays of integers and
- floating-point numbers, thereafter referred to as ``big arrays''.
+ floating-point numbers, thereafter referred to as 'big arrays'.
The implementation allows efficient sharing of large numerical
arrays between OCaml code and C or Fortran numerical libraries.
= "caml_ba_slice"
(** Extract a sub-array of lower dimension from the given big array
by fixing one or several of the first (left-most) coordinates.
- [Genarray.slice_left a [|i1; ... ; iM|]] returns the ``slice''
+ [Genarray.slice_left a [|i1; ... ; iM|]] returns the 'slice'
of [a] obtained by setting the first [M] coordinates to
[i1], ..., [iM]. If [a] has [N] dimensions, the slice has
dimension [N - M], and the element at coordinates
= "caml_ba_slice"
(** Extract a sub-array of lower dimension from the given big array
by fixing one or several of the last (right-most) coordinates.
- [Genarray.slice_right a [|i1; ... ; iM|]] returns the ``slice''
+ [Genarray.slice_right a [|i1; ... ; iM|]] returns the 'slice'
of [a] obtained by setting the last [M] coordinates to
[i1], ..., [iM]. If [a] has [N] dimensions, the slice has
dimension [N - M], and the element at coordinates
determine the array element kind and the array layout
as described for [Genarray.create]. *)
- val dim: ('a, 'b, 'c) t -> int
+ external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
(** Return the size (dimension) of the given one-dimensional
big array. *)
determine the array element kind and the array layout
as described for {!Bigarray.Genarray.create}. *)
- val dim1: ('a, 'b, 'c) t -> int
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
(** Return the first dimension of the given two-dimensional big array. *)
- val dim2: ('a, 'b, 'c) t -> int
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
(** Return the second dimension of the given two-dimensional big array. *)
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
[kind] and [layout] determine the array element kind and
the array layout as described for {!Bigarray.Genarray.create}. *)
- val dim1: ('a, 'b, 'c) t -> int
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
(** Return the first dimension of the given three-dimensional big array. *)
- val dim2: ('a, 'b, 'c) t -> int
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
(** Return the second dimension of the given three-dimensional big array. *)
- val dim3: ('a, 'b, 'c) t -> int
+ external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
(** Return the third dimension of the given three-dimensional big array. *)
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
/* */
/***********************************************************************/
-/* $Id: bigarray_stubs.c 12963 2012-09-27 15:48:40Z doligez $ */
-
#include <stddef.h>
#include <stdarg.h>
#include <string.h>
if (data == NULL && size != 0) caml_raise_out_of_memory();
flags |= CAML_BA_MANAGED;
}
- /* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
- asize = sizeof(struct caml_ba_array) + num_dims * sizeof(intnat);
-#else
- asize = sizeof(struct caml_ba_array) + (num_dims - 1) * sizeof(intnat);
-#endif
+ asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY);
b = Caml_ba_array_val(res);
b->data = data;
return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind));
}
+
+CAMLprim value caml_ba_uint8_get16(value vb, value vind)
+{
+ intnat res;
+ unsigned char b1, b2;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+ b1 = ((unsigned char*) b->data)[idx];
+ b2 = ((unsigned char*) b->data)[idx+1];
+#ifdef ARCH_BIG_ENDIAN
+ res = b1 << 8 | b2;
+#else
+ res = b2 << 8 | b1;
+#endif
+ return Val_int(res);
+}
+
+CAMLprim value caml_ba_uint8_get32(value vb, value vind)
+{
+ intnat res;
+ unsigned char b1, b2, b3, b4;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+ b1 = ((unsigned char*) b->data)[idx];
+ b2 = ((unsigned char*) b->data)[idx+1];
+ b3 = ((unsigned char*) b->data)[idx+2];
+ b4 = ((unsigned char*) b->data)[idx+3];
+#ifdef ARCH_BIG_ENDIAN
+ res = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+#else
+ res = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+ return caml_copy_int32(res);
+}
+
+#ifdef ARCH_INT64_TYPE
+#include "int64_native.h"
+#else
+#include "int64_emul.h"
+#endif
+
+CAMLprim value caml_ba_uint8_get64(value vb, value vind)
+{
+ uint32 reshi;
+ uint32 reslo;
+ unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+ b1 = ((unsigned char*) b->data)[idx];
+ b2 = ((unsigned char*) b->data)[idx+1];
+ b3 = ((unsigned char*) b->data)[idx+2];
+ b4 = ((unsigned char*) b->data)[idx+3];
+ b5 = ((unsigned char*) b->data)[idx+4];
+ b6 = ((unsigned char*) b->data)[idx+5];
+ b7 = ((unsigned char*) b->data)[idx+6];
+ b8 = ((unsigned char*) b->data)[idx+7];
+#ifdef ARCH_BIG_ENDIAN
+ reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+ reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8;
+#else
+ reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5;
+ reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+ return caml_copy_int64(I64_literal(reshi,reslo));
+}
+
/* Generic write to a big array */
static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
}
+CAMLprim value caml_ba_uint8_set16(value vb, value vind, value newval)
+{
+ unsigned char b1, b2;
+ intnat val;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+ val = Long_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 8;
+ b2 = 0xFF & val;
+#else
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ ((unsigned char*) b->data)[idx] = b1;
+ ((unsigned char*) b->data)[idx+1] = b2;
+ return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set32(value vb, value vind, value newval)
+{
+ unsigned char b1, b2, b3, b4;
+ intnat idx = Long_val(vind);
+ intnat val;
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+ val = Int32_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 24;
+ b2 = 0xFF & val >> 16;
+ b3 = 0xFF & val >> 8;
+ b4 = 0xFF & val;
+#else
+ b4 = 0xFF & val >> 24;
+ b3 = 0xFF & val >> 16;
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ ((unsigned char*) b->data)[idx] = b1;
+ ((unsigned char*) b->data)[idx+1] = b2;
+ ((unsigned char*) b->data)[idx+2] = b3;
+ ((unsigned char*) b->data)[idx+3] = b4;
+ return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval)
+{
+ unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+ uint32 lo,hi;
+ intnat idx = Long_val(vind);
+ int64 val;
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+ val = Int64_val(newval);
+ I64_split(val,hi,lo);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & hi >> 24;
+ b2 = 0xFF & hi >> 16;
+ b3 = 0xFF & hi >> 8;
+ b4 = 0xFF & hi;
+ b5 = 0xFF & lo >> 24;
+ b6 = 0xFF & lo >> 16;
+ b7 = 0xFF & lo >> 8;
+ b8 = 0xFF & lo;
+#else
+ b8 = 0xFF & hi >> 24;
+ b7 = 0xFF & hi >> 16;
+ b6 = 0xFF & hi >> 8;
+ b5 = 0xFF & hi;
+ b4 = 0xFF & lo >> 24;
+ b3 = 0xFF & lo >> 16;
+ b2 = 0xFF & lo >> 8;
+ b1 = 0xFF & lo;
+#endif
+ ((unsigned char*) b->data)[idx] = b1;
+ ((unsigned char*) b->data)[idx+1] = b2;
+ ((unsigned char*) b->data)[idx+2] = b3;
+ ((unsigned char*) b->data)[idx+3] = b4;
+ ((unsigned char*) b->data)[idx+4] = b5;
+ ((unsigned char*) b->data)[idx+5] = b6;
+ ((unsigned char*) b->data)[idx+6] = b7;
+ ((unsigned char*) b->data)[idx+7] = b8;
+ return Val_unit;
+}
+
/* Return the number of dimensions of a big array */
CAMLprim value caml_ba_num_dims(value vb)
return Val_long(b->dim[n]);
}
+CAMLprim value caml_ba_dim_1(value vb)
+{
+ return caml_ba_dim(vb, Val_int(0));
+}
+
+CAMLprim value caml_ba_dim_2(value vb)
+{
+ return caml_ba_dim(vb, Val_int(1));
+}
+
+CAMLprim value caml_ba_dim_3(value vb)
+{
+ return caml_ba_dim(vb, Val_int(2));
+}
+
/* Return the kind of a big array */
CAMLprim value caml_ba_kind(value vb)
}
/* Compute required size in OCaml heap. Assumes struct caml_ba_array
is exactly 4 + num_dims words */
- /* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
- Assert(sizeof(struct caml_ba_array) == 4 * sizeof(value));
-#else
- Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value));
-#endif
+ Assert(SIZEOF_BA_ARRAY == 4 * sizeof(value));
*wsize_32 = (4 + b->num_dims) * 4;
*wsize_64 = (4 + b->num_dims) * 8;
}
caml_ba_deserialize_longarray(b->data, num_elts); break;
}
/* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
- return sizeof(struct caml_ba_array) + b->num_dims * sizeof(intnat);
-#else
- return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat);
-#endif
+ return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
}
/* Create / update proxy to indicate that b2 is a sub-array of b1 */
/* */
/***********************************************************************/
-/* $Id: mmap_unix.c 12800 2012-07-30 18:59:07Z doligez $ */
-
/* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
Must be defined before the first system .h is included. */
#define _XOPEN_SOURCE 500
/* */
/***********************************************************************/
-/* $Id: mmap_win32.c 12149 2012-02-10 16:15:24Z doligez $ */
-
#include <stddef.h>
#include <stdio.h>
#include <string.h>
# #
#########################################################################
-# $Id: Makefile 12511 2012-05-30 13:29:48Z lefessan $
-
# Makefile for the dynamic link library
include ../../config/Makefile
CAMLC=../../boot/ocamlrun ../../ocamlc
CAMLOPT=../../ocamlcompopt.sh
INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp
-COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES)
+COMPFLAGS=-w +33..39 -warn-error A -I ../../stdlib $(INCLUDES)
OBJS=dynlinkaux.cmo dynlink.cmo
allopt: dynlink.cmxa
dynlink.cma: $(OBJS)
- $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma $(OBJS)
+ $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \
+ $(OBJS)
dynlink.cmxa: $(NATOBJS)
- $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa $(NATOBJS)
+ $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \
+ $(NATOBJS)
dynlinkaux.cmo: $(COMPILEROBJS)
$(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS)
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the dynamic link library
include Makefile
(* *)
(***********************************************************************)
-(* $Id: dynlink.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Dynamic loading of .cmo files *)
open Dynlinkaux (* REMOVE_ME for ../../debugger/dynlink.ml *)
exception Error of error
+let () =
+ Printexc.register_printer
+ (function
+ | Error err ->
+ let msg = match err with
+ | Not_a_bytecode_file s ->
+ Printf.sprintf "Not_a_bytecode_file %S" s
+ | Inconsistent_import s ->
+ Printf.sprintf "Inconsistent_import %S" s
+ | Unavailable_unit s ->
+ Printf.sprintf "Unavailable_unit %S" s
+ | Unsafe_file ->
+ "Unsafe_file"
+ | Linking_error (s, Undefined_global s') ->
+ Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)"
+ s s'
+ | Linking_error (s, Unavailable_primitive s') ->
+ Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive \
+ %S)" s s'
+ | Linking_error (s, Uninitialized_global s') ->
+ Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global \
+ %S)" s s'
+ | Corrupted_interface s ->
+ Printf.sprintf "Corrupted_interface %S" s
+ | File_not_found s ->
+ Printf.sprintf "File_not_found %S" s
+ | Cannot_open_dll s ->
+ Printf.sprintf "Cannot_open_dll %S" s
+ | Inconsistent_implementation s ->
+ Printf.sprintf "Inconsistent_implementation %S" s in
+ Some (Printf.sprintf "Dynlink.Error(Dynlink.%s)" msg)
+ | _ -> None)
+
(* Management of interface CRCs *)
let crc_interfaces = ref (Consistbl.create ())
let loadfile file_name =
init();
- if not (Sys.file_exists file_name) then raise(Error (File_not_found file_name));
+ if not (Sys.file_exists file_name)
+ then raise (Error (File_not_found file_name));
let ic = open_in_bin file_name in
let file_digest = Digest.channel ic (-1) in
seek_in ic 0;
(* *)
(***********************************************************************)
-(* $Id: dynlink.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Dynamic loading of object files. *)
val is_native: bool
val allow_unsafe_modules : bool -> unit
(** Govern whether unsafe object files are allowed to be
- dynamically linked. A compilation unit is ``unsafe'' if it contains
+ dynamically linked. A compilation unit is 'unsafe' if it contains
declarations of external functions, which can break type safety.
By default, dynamic linking of unsafe object files is
not allowed. In native code, this function does nothing; object files
(* *)
(***********************************************************************)
-(* $Id: extract_crc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Print the digests of unit interfaces *)
let load_path = ref []
(* *)
(***********************************************************************)
-(* $Id: natdynlink.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Dynamic loading of .cmx files *)
type handle
../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../byterun/../config/m.h \
../../byterun/../config/s.h ../../byterun/misc.h \
-
+
draw.o: draw.c libgraph.h \
\
\
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the portable graphics library
LIBNAME=graphics
include ../Makefile
depend:
- gcc -MM $(CFLAGS) *.c | sed -e 's, /usr[^ ]*\.h,,g' > .depend
+ gcc -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
include .depend
/* */
/***********************************************************************/
-/* $Id: color.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include <X11/Xatom.h>
fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r);
#endif
for(i=0; i<256; i++){
- caml_gr_green_vals[i] = (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l;
+ caml_gr_green_vals[i] =
+ (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l;
}
caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r);
fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r);
#endif
for(i=0; i<256; i++){
- caml_gr_blue_vals[i] = (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l;
+ caml_gr_blue_vals[i] =
+ (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l;
}
if( caml_gr_red_l < 0 || caml_gr_red_r < 0 ||
int i;
if (caml_gr_direct_rgb) {
- r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) >> (16 - caml_gr_red_r);
- g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) >> (16 - caml_gr_green_r);
- b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) >> (16 - caml_gr_blue_r);
+ r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8)
+ >> (16 - caml_gr_red_r);
+ g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8)
+ >> (16 - caml_gr_green_r);
+ b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8)
+ >> (16 - caml_gr_blue_r);
return (r << 16) + (g << 8) + b;
}
/* */
/***********************************************************************/
-/* $Id: draw.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include <alloc.h>
int y = Int_val(vy);
caml_gr_check_open();
if(caml_gr_remember_modeflag)
- XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y));
+ XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x,
+ Bcvt(y));
if(caml_gr_display_modeflag) {
- XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y));
+ XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x,
+ Wcvt(y));
XFlush(caml_gr_display);
}
return Val_unit;
return Val_unit;
}
-value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
+value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1,
+ value va2)
{
int x = Int_val(vx);
int y = Int_val(vy);
value caml_gr_draw_arc(value *argv, int argc)
{
- return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+ return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4],
+ argv[5]);
}
value caml_gr_set_line_width(value vwidth)
/* */
/***********************************************************************/
-/* $Id: dump_img.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include "image.h"
#include <alloc.h>
}
idata =
- XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), ZPixmap);
+ XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1),
+ ZPixmap);
for (i = 0; i < height; i++)
for (j = 0; j < width; j++)
- Field(Field(m, i), j) = Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
+ Field(Field(m, i), j) =
+ Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
XDestroyImage(idata);
if (Mask_im(image) != None) {
imask =
- XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, ZPixmap);
+ XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1,
+ ZPixmap);
for (i = 0; i < height; i++)
for (j = 0; j < width; j++)
if (XGetPixel(imask, j, i) == 0)
/* */
/***********************************************************************/
-/* $Id: events.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <signal.h>
#include "libgraph.h"
#include <alloc.h>
switch (event->type) {
case Expose:
- XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc,
- event->xexpose.x, event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h,
+ XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win,
+ caml_gr_window.gc,
+ event->xexpose.x,
+ event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h,
event->xexpose.width, event->xexpose.height,
event->xexpose.x, event->xexpose.y);
XFlush(caml_gr_display);
case ConfigureNotify:
caml_gr_window.w = event->xconfigure.width;
caml_gr_window.h = event->xconfigure.height;
- if (caml_gr_window.w > caml_gr_bstore.w || caml_gr_window.h > caml_gr_bstore.h) {
+ if (caml_gr_window.w > caml_gr_bstore.w
+ || caml_gr_window.h > caml_gr_bstore.h) {
/* Allocate a new backing store large enough to accomodate
both the old backing store and the current window. */
newbstore.w = max(caml_gr_window.w, caml_gr_bstore.w);
newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h);
newbstore.win =
- XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, newbstore.h,
+ XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w,
+ newbstore.h,
XDefaultDepth(caml_gr_display, caml_gr_screen));
newbstore.gc = XCreateGC(caml_gr_display, newbstore.win, 0, NULL);
XSetBackground(caml_gr_display, newbstore.gc, caml_gr_white);
XSetFont(caml_gr_display, newbstore.gc, caml_gr_font->fid);
/* Copy the old backing store into the new one */
- XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, newbstore.gc,
- 0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, newbstore.h - caml_gr_bstore.h);
+ XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win,
+ newbstore.gc,
+ 0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0,
+ newbstore.h - caml_gr_bstore.h);
/* Free the old backing store */
XFreeGC(caml_gr_display, caml_gr_bstore.gc);
unsigned int modifiers;
unsigned int i;
+ caml_process_pending_signals ();
if (XQueryPointer(caml_gr_display, caml_gr_window.win,
&rootwin, &childwin,
&root_x, &root_y, &win_x, &win_y,
break;
}
}
- return caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
+ return
+ caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
}
static value caml_gr_wait_event_in_queue(long mask)
/* */
/***********************************************************************/
-/* $Id: fill.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include <memory.h>
caml_gr_check_open();
npoints = Wosize_val(array);
- points = (XPoint *) stat_alloc(npoints * sizeof(XPoint));
+ points = (XPoint *) caml_stat_alloc(npoints * sizeof(XPoint));
for (i = 0; i < npoints; i++) {
points[i].x = Int_val(Field(Field(array, i), 0));
points[i].y = Bcvt(Int_val(Field(Field(array, i), 1)));
return Val_unit;
}
-value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
+value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1,
+ value va2)
{
int x = Int_val(vx);
int y = Int_val(vy);
value caml_gr_fill_arc(value *argv, int argc)
{
- return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+ return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4],
+ argv[5]);
}
(* *)
(***********************************************************************)
-(* $Id: graphics.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
exception Graphic_failure of string
(* Initializations *)
let key_pressed () =
let e = wait_next_event [Poll] in e.keypressed
+let loop_at_exit events handler =
+ let events = List.filter (fun e -> e <> Poll) events in
+ at_exit (fun _ ->
+ try
+ while true do
+ let e = wait_next_event events in
+ handler e
+ done
+ with Exit -> close_graph ()
+ | e -> close_graph (); raise e
+ )
+
(*** Sound *)
external sound : int -> int -> unit = "caml_gr_sound"
(* *)
(***********************************************************************)
-(* $Id: graphics.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Machine-independent graphics primitives. *)
exception Graphic_failure of string
Externally, images are represented as matrices of colors. *)
val transp : color
-(** In matrices of colors, this color represent a ``transparent''
+(** In matrices of colors, this color represent a 'transparent'
point: when drawing the corresponding image, all pixels on the
screen corresponding to a transparent pixel in the image will
not be modified, while other points will be set to the color
are queued, and dequeued one by one when the [Key_pressed]
event is specified. *)
+val loop_at_exit : event list -> (status -> unit) -> unit
+(** Loop before exiting the program, the list given as argument is the
+ list of handlers and the events on which these handlers are called.
+ To exit cleanly the loop, the handler should raise Exit. Any other
+ exception will be propagated outside of the loop.
+ @since 4.01
+*)
+
(** {6 Mouse and keyboard polling} *)
val mouse_pos : unit -> int * int
val auto_synchronize : bool -> unit
(** By default, drawing takes place both on the window displayed
- on screen, and in a memory area (the ``backing store'').
+ on screen, and in a memory area (the 'backing store').
The backing store image is used to re-paint the on-screen
window when necessary.
(* *)
(***********************************************************************)
-(* $Id: graphicsX11.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-(* Module [GraphicsX11]: additional graphics primitives for the X Windows system *)
+(* Module [GraphicsX11]: additional graphics primitives for
+ the X Windows system *)
type window_id = string
close_subwindow wid;
Hashtbl.remove subwindows wid
end else
- raise (Graphics.Graphic_failure ("close_subwindow: no such subwindow: " ^ wid))
+ raise (Graphics.Graphic_failure("close_subwindow: no such subwindow: "^wid))
;;
(* *)
(***********************************************************************)
-(* $Id: graphicsX11.mli 12149 2012-02-10 16:15:24Z doligez $ *)
-
(** Additional graphics primitives for the X Windows system. *)
type window_id = string
/* */
/***********************************************************************/
-/* $Id: image.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include "image.h"
#include <alloc.h>
}
}
if(caml_gr_remember_modeflag)
- XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, caml_gr_bstore.gc,
+ XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win,
+ caml_gr_bstore.gc,
0, 0,
Width_im(im), Height_im(im),
x, by);
if(caml_gr_display_modeflag)
- XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, caml_gr_window.gc,
+ XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win,
+ caml_gr_window.gc,
0, 0,
Width_im(im), Height_im(im),
x, wy);
XFlush(caml_gr_display);
return Val_unit;
}
-
-/* eof $Id: image.c 11156 2011-07-27 14:17:02Z doligez $ */
/* */
/***********************************************************************/
-/* $Id: image.h 11156 2011-07-27 14:17:02Z doligez $ */
-
struct grimage {
int width, height; /* Dimensions of the image */
Pixmap data; /* Pixels */
/* */
/***********************************************************************/
-/* $Id: libgraph.h 12149 2012-02-10 16:15:24Z doligez $ */
-
#include <stdio.h>
#include <X11/Xlib.h>
#include <X11/Xutil.h>
(used for CAML color -1) */
extern Bool caml_gr_display_modeflag; /* Display-mode flag */
extern Bool caml_gr_remember_modeflag; /* Remember-mode flag */
-extern int caml_gr_x, caml_gr_y; /* Coordinates of the current point */
-extern int caml_gr_color; /* Current *CAML* drawing color (can be -1) */
+extern int caml_gr_x, caml_gr_y; /* Coordinates of the current point */
+extern int caml_gr_color; /* Current *CAML* drawing color (can be -1) */
extern XFontStruct * caml_gr_font; /* Current font */
extern long caml_gr_selected_events; /* Events we are interested in */
extern Bool caml_gr_ignore_sigio; /* Whether to consume events on sigio */
/* */
/***********************************************************************/
-/* $Id: make_img.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include "image.h"
#include <memory.h>
/* Build an XImage for the data part of the image */
idata =
- XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen),
+ XCreateImage(caml_gr_display,
+ DefaultVisual(caml_gr_display, caml_gr_screen),
XDefaultDepth(caml_gr_display, caml_gr_screen),
ZPixmap, 0, NULL, width, height,
BitmapPad(caml_gr_display), 0);
- bdata = (char *) stat_alloc(height * idata->bytes_per_line);
+ bdata = (char *) caml_stat_alloc(height * idata->bytes_per_line);
idata->data = bdata;
has_transp = False;
build an XImage for the mask part of the image */
if (has_transp) {
imask =
- XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen),
+ XCreateImage(caml_gr_display,
+ DefaultVisual(caml_gr_display, caml_gr_screen),
1, ZPixmap, 0, NULL, width, height,
BitmapPad(caml_gr_display), 0);
- bmask = (char *) stat_alloc(height * imask->bytes_per_line);
+ bmask = (char *) caml_stat_alloc(height * imask->bytes_per_line);
imask->data = bmask;
for (i = 0; i < height; i++) {
XDestroyImage(idata);
XFreeGC(caml_gr_display, gc);
if (has_transp) {
- Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, height, 1);
+ Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width,
+ height, 1);
gc = XCreateGC(caml_gr_display, Mask_im(im), 0, NULL);
- XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height);
+ XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width,
+ height);
XDestroyImage(imask);
XFreeGC(caml_gr_display, gc);
}
/* */
/***********************************************************************/
-/* $Id: open.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <fcntl.h>
#include <signal.h>
hints.flags = PPosition | PSize;
hints.win_gravity = 0;
- ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", BORDER_WIDTH,
+ ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "",
+ BORDER_WIDTH,
&hints, &x, &y, &w, &h, &hints.win_gravity);
if (ret & (XValue | YValue)) {
hints.x = x; hints.y = y; hints.flags |= USPosition;
caml_gr_bstore.w = caml_gr_window.w;
caml_gr_bstore.h = caml_gr_window.h;
caml_gr_bstore.win =
- XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, caml_gr_bstore.h,
+ XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w,
+ caml_gr_bstore.h,
XDefaultDepth(caml_gr_display, caml_gr_screen));
caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL);
XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background);
setitimer(ITIMER_REAL, &it, NULL);
#endif
caml_gr_initialized = False;
- if (caml_gr_font != NULL) { XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; }
+ if (caml_gr_font != NULL) {
+ XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL;
+ }
XFreeGC(caml_gr_display, caml_gr_window.gc);
XDestroyWindow(caml_gr_display, caml_gr_window.win);
XFreeGC(caml_gr_display, caml_gr_bstore.gc);
value caml_gr_set_window_title(value n)
{
if (window_name != NULL) stat_free(window_name);
- window_name = stat_alloc(strlen(String_val(n))+1);
+ window_name = caml_stat_alloc(strlen(String_val(n))+1);
strcpy(window_name, String_val(n));
if (caml_gr_initialized) {
XStoreName(caml_gr_display, caml_gr_window.win, window_name);
value caml_gr_synchronize(void)
{
caml_gr_check_open();
- XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc,
+ XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win,
+ caml_gr_window.gc,
0, caml_gr_bstore.h - caml_gr_window.h,
caml_gr_window.w, caml_gr_window.h,
0, 0);
if (graphic_failure_exn == NULL) {
graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
if (graphic_failure_exn == NULL)
- invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma");
+ invalid_argument("Exception Graphics.Graphic_failure not initialized,"
+ " must link graphics.cma");
}
sprintf(buffer, fmt, arg);
raise_with_string(*graphic_failure_exn, buffer);
/* */
/***********************************************************************/
-/* $Id: point_col.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
value caml_gr_point_color(value vx, value vy)
int rgb;
caml_gr_check_open();
- im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap);
+ im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1),
+ ZPixmap);
rgb = caml_gr_rgb_pixel(XGetPixel(im, 0, 0));
XDestroyImage(im);
return Val_int(rgb);
/* */
/***********************************************************************/
-/* $Id: sound.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
value caml_gr_sound(value vfreq, value vdur)
/* */
/***********************************************************************/
-/* $Id: subwindow.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
value caml_gr_open_subwindow(value vx, value vy, value width, value height)
/* */
/***********************************************************************/
-/* $Id: text.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "libgraph.h"
#include <alloc.h>
if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
if (caml_gr_remember_modeflag)
XDrawString(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
- caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len);
+ caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt,
+ len);
if (caml_gr_display_modeflag) {
XDrawString(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
- caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len);
+ caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt,
+ len);
XFlush(caml_gr_display);
}
caml_gr_x += XTextWidth(caml_gr_font, txt, len);
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
+# $Id$
OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
+# $Id$
OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads
(* *)
(*************************************************************************)
-(* $Id: dummyUnix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
module Mutex : sig
type t
(* *)
(*************************************************************************)
-(* $Id: dummyWin.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* *)
(*************************************************************************)
-(* $Id: editor.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
open StdLabels
open Tk
(* *)
(*************************************************************************)
-(* $Id: editor.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: fileselect.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* file selection box *)
(* *)
(*************************************************************************)
-(* $Id: fileselect.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val f :
title:string ->
(* *)
(*************************************************************************)
-(* $Id: jg_bind.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_bind.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: jg_box.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_button.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_completion.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
let lt_string ?(nocase=false) s1 s2 =
if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2
(* *)
(*************************************************************************)
-(* $Id: jg_completion.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val lt_string : ?nocase:bool -> string -> string -> bool
(* *)
(*************************************************************************)
-(* $Id: jg_config.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
open Jg_tk
(* *)
(*************************************************************************)
-(* $Id: jg_config.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val init: unit -> unit
(* *)
(*************************************************************************)
-(* $Id: jg_entry.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_memo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
type ('a, 'b) assoc_list =
Nil
(* *)
(*************************************************************************)
-(* $Id: jg_memo.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val fast : f:('a -> 'b) -> 'a -> 'b
(* "fast" memoizer: uses a List.assq like function *)
(* *)
(*************************************************************************)
-(* $Id: jg_menu.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_message.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_message.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: jg_multibox.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
(* *)
(*************************************************************************)
-(* $Id: jg_multibox.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
class c :
cols:int -> texts:string list ->
(* *)
(*************************************************************************)
-(* $Id: jg_text.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_text.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: jg_tk.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: jg_toplevel.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
(* *)
(*************************************************************************)
-(* $Id: lexical.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
open Tk
(* *)
(*************************************************************************)
-(* $Id: lexical.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: list2.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
(* *)
(*************************************************************************)
-(* $Id: main.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
module Unix = UnixLabels
(* *)
(*************************************************************************)
-(* $Id: mytypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: searchid.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
open Asttypes
open StdLabels
~f:(fun acc x -> Pdot (acc, x, 0))
let get_fields ~prefix ~sign self =
- let env = open_signature (mkpath prefix) sign initial in
+ let env = open_signature Fresh (mkpath prefix) sign initial in
match (expand_head env self).desc with
Tobject (ty_obj, _) ->
let l,_ = flatten_fields ty_obj in l
end in
try (Typemod.transl_signature env sexp).sig_type
with Env.Error err -> []
- | Typemod.Error (l,_) ->
+ | Typemod.Error (l,_,_) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
- | Typetexp.Error (l,_) ->
+ | Typetexp.Error (l,_,_) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
(* *)
(*************************************************************************)
-(* $Id: searchid.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val start_env : Env.t ref
val module_list : string list ref
(* *)
(*************************************************************************)
-(* $Id: searchpos.ml 12681 2012-07-10 08:33:16Z garrigue $ *)
+(* $Id$ *)
open Asttypes
open StdLabels
List.fold_left l ~init:env ~f:
begin fun env pt ->
let env = match pt.psig_desc with
- Psig_open id ->
+ Psig_open (ovf, id) ->
let path, mt = lookup_module id.txt env in
begin match mt with
- Mty_signature sign -> open_signature path sign env
+ Mty_signature sign -> open_signature ovf path sign env
| _ -> env
end
| sign_item ->
List.iter l
~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
(* The last cases should not happen in generated interfaces *)
- | Psig_open lid -> add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc
+ | Psig_open (_, lid) ->
+ add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc
| Psig_include t -> search_pos_module t ~pos ~env
end;
env
let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
let env =
match path with None -> env
- | Some path -> Env.open_signature path sign env in
+ | Some path -> Env.open_signature Fresh path sign env in
let title =
match title, path with Some title, _ -> title
| None, Some path -> string_of_path path
tl, tw, finish
in
Format.set_max_boxes 100;
- Printtyp.signature Format.std_formatter sign;
+ Printtyp.wrap_printing_env env
+ (fun () -> Printtyp.signature Format.std_formatter sign);
finish ();
Lexical.init_tags tw;
Lexical.tag tw;
let pt =
try Parse.interface (Lexing.from_string text)
with Syntaxerr.Error e ->
- let l =
- match e with
- Syntaxerr.Unclosed(l,_,_,_) -> l
- | Syntaxerr.Applicative_path l -> l
- | Syntaxerr.Variable_in_scope(l,_) -> l
- | Syntaxerr.Other l -> l
- in
+ let l = Syntaxerr.location_of_error e in
Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; []
| Lexer.Error (_, l) ->
Format.set_formatter_output_functions buf#out (fun () -> ());
Format.set_margin 60;
Format.open_hbox ();
- if kind = `Type then
- Printtyp.type_declaration
- (ident_of_path path ~default:"t")
- Format.std_formatter
- (find_type path env)
- else
- Printtyp.modtype_declaration
- (ident_of_path path ~default:"S")
- Format.std_formatter
- (find_modtype path env);
+ Printtyp.wrap_printing_env env begin fun () ->
+ if kind = `Type then
+ Printtyp.type_declaration
+ (ident_of_path path ~default:"t")
+ Format.std_formatter
+ (find_type path env)
+ else
+ Printtyp.modtype_declaration
+ (ident_of_path path ~default:"S")
+ Format.std_formatter
+ (find_modtype path env)
+ end;
Format.close_box (); Format.print_flush ();
Format.set_formatter_output_functions fo ff;
Format.set_margin margin;
Format.open_hbox ();
Printtyp.reset ();
Printtyp.mark_loops ty;
- Printtyp.type_expr Format.std_formatter ty;
+ Printtyp.wrap_printing_env env
+ (fun () -> Printtyp.type_expr Format.std_formatter ty);
Format.close_box (); Format.print_flush ();
Format.set_formatter_output_functions fo ff;
Format.set_margin margin;
search_pos_expr exp ~pos
end
| Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
- | Texp_construct (_, _, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
+ | Texp_construct (_, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
| Texp_variant (_, None) -> ()
| Texp_variant (_, Some exp) -> search_pos_expr exp ~pos
| Texp_record (l, opt) ->
- List.iter l ~f:(fun (_, _, _, exp) -> search_pos_expr exp ~pos);
+ List.iter l ~f:(fun (_, _, exp) -> search_pos_expr exp ~pos);
(match opt with None -> () | Some exp -> search_pos_expr exp ~pos)
- | Texp_field (exp, _, _, _) -> search_pos_expr exp ~pos
- | Texp_setfield (a, _, _, _, b) ->
+ | Texp_field (exp, _, _) -> search_pos_expr exp ~pos
+ | Texp_setfield (a, _, _, b) ->
search_pos_expr a ~pos; search_pos_expr b ~pos
| Texp_array l -> List.iter l ~f:(search_pos_expr ~pos)
| Texp_ifthenelse (a, b, c) ->
add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
| Tpat_tuple l ->
List.iter l ~f:(search_pos_pat ~pos ~env)
- | Tpat_construct (_, _, _, l, _) ->
+ | Tpat_construct (_, _, l, _) ->
List.iter l ~f:(search_pos_pat ~pos ~env)
| Tpat_variant (_, None, _) -> ()
| Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env
| Tpat_record (l, _) ->
- List.iter l ~f:(fun (_, _, _, pat) -> search_pos_pat pat ~pos ~env)
+ List.iter l ~f:(fun (_, _, pat) -> search_pos_pat pat ~pos ~env)
| Tpat_array l ->
List.iter l ~f:(search_pos_pat ~pos ~env)
| Tpat_or (a, b, None) ->
(* *)
(*************************************************************************)
-(* $Id: searchpos.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: setpath.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
open Tk
(* *)
(*************************************************************************)
-(* $Id: setpath.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(*************************************************************************)
-(* $Id: shell.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
module Unix = UnixLabels
(* *)
(*************************************************************************)
-(* $Id: shell.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
class ['a] history :
unit ->
(* *)
(*************************************************************************)
-(* $Id: typecheck.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
open StdLabels
open Tk
Lexer.report_error Format.std_formatter err; l
| Syntaxerr.Error err ->
Syntaxerr.report_error Format.std_formatter err;
- begin match err with
- Syntaxerr.Unclosed(l,_,_,_) -> l
- | Syntaxerr.Applicative_path l -> l
- | Syntaxerr.Variable_in_scope(l,_) -> l
- | Syntaxerr.Other l -> l
- end
- | Typecore.Error (l,err) ->
- Typecore.report_error Format.std_formatter err; l
- | Typeclass.Error (l,err) ->
- Typeclass.report_error Format.std_formatter err; l
+ Syntaxerr.location_of_error err
+ | Typecore.Error (l, env, err) ->
+ Typecore.report_error env Format.std_formatter err; l
+ | Typeclass.Error (l, env, err) ->
+ Typeclass.report_error env Format.std_formatter err; l
| Typedecl.Error (l, err) ->
Typedecl.report_error Format.std_formatter err; l
- | Typemod.Error (l,err) ->
- Typemod.report_error Format.std_formatter err; l
- | Typetexp.Error (l,err) ->
- Typetexp.report_error Format.std_formatter err; l
+ | Typemod.Error (l, env, err) ->
+ Typemod.report_error env Format.std_formatter err; l
+ | Typetexp.Error (l, env, err) ->
+ Typetexp.report_error env Format.std_formatter err; l
| Includemod.Error errl ->
Includemod.report_error Format.std_formatter errl; Location.none
| Env.Error err ->
(* *)
(*************************************************************************)
-(* $Id: typecheck.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
open Mytypes
(* *)
(*************************************************************************)
-(* $Id: useunix.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
open UnixLabels
(* *)
(*************************************************************************)
-(* $Id: useunix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Unix utilities *)
(* *)
(*************************************************************************)
-(* $Id: viewer.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
open StdLabels
open Tk
let path, vd = lookup_value id env in
view_signature_item ~path ~env [Sig_value (Ident.create name, vd)]
| Ptype -> view_type_id id ~env
- | Plabel -> let _,ld = lookup_label id env in
+ | Plabel -> let ld = lookup_label id env in
begin match ld.lbl_res.desc with
Tconstr (path, _, _) -> view_type_decl path ~env
| _ -> ()
end
| Pconstructor ->
- let _,cd = lookup_constructor id env in
+ let cd = lookup_constructor id env in
begin match cd.cstr_res.desc with
Tconstr (cpath, _, _) ->
if Path.same cpath Predef.path_exn then
in
let l = iter_sign sign [] in
let title = string_of_path path in
- let env = open_signature path sign env in
+ let env = open_signature Asttypes.Fresh path sign env in
!choose_symbol_ref l ~title ~signature:sign ~env ~path;
if show_all then view_signature sign ~title ~env ~path
| _ -> ()
(* *)
(*************************************************************************)
-(* $Id: viewer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Module viewer *)
open Widget
/* */
/*************************************************************************/
-/* $Id: winmain.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
#include <windows.h>
#include <mlvalues.h>
(* *)
(*************************************************************************)
-(* $Id: LICENSE 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
All the files in this directory are subject to the above copyright notice.
include ./modules
-CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo
+CAMLTKOBJS = $(CWIDGETOBJS) cTk.cmo camltk.cmo
CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx)
camltkobjs: $(CAMLTKOBJS)
camltkobjsx: $(CAMLTKOBJSX)
-clean:
- $(MAKE) -f Makefile.gen clean
-
install:
if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
+ cp $(CAMLTKOBJS:.cmo=.cmi) $(INSTALLDIR)
+ cp $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
chmod 644 $(INSTALLDIR)/*.cmi
installopt:
cp $(CAMLTKOBJSX) $(INSTALLDIR)
chmod 644 $(INSTALLDIR)/*.cmx
+clean:
+ $(MAKE) -f Makefile.gen clean
+
.SUFFIXES :
.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile.gen
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
-CWIDGETOBJS=cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
+CWIDGETOBJS= cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml
cBell.cmo : cBell.ml
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
(* *)
(***********************************************************************)
-(* $Id: compile.ml 12149 2012-02-10 16:15:24Z doligez $ *)
+(* $Id$ *)
open StdLabels
open Tables
(* *)
(***********************************************************************)
-(* $Id: intf.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
(* *)
(***********************************************************************)
-(* $Id: lexer.mll 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
{
open StdLabels
open Lexing
open Parser
-open Support
exception Lexical_error of string
let current_line = ref 1
(* *)
(***********************************************************************)
-(* $Id: maincompile.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
-open Support
open Tables
open Printer
open Compile
Hashtbl.iter
(fun name _ ->
let name = realname name in
+ output_string oc " ";
output_string oc name;
- output_string oc ".cmo ")
+ output_string oc ".cmo")
module_table;
output_string oc "\n";
Hashtbl.iter
/* */
/***********************************************************************/
-/* $Id: parser.mly 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
%{
let more = ref 0 in
for i = 0 to String.length s - 1 do
match s.[i] with
- | '\\' | '"' -> incr more
+ | '\\' | '\"' | '\'' -> incr more
| _ -> ()
done;
if !more = 0 then s else
for i = 0 to String.length s - 1 do
let c = s.[i] in
match c with
- | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j
+ | '\\' | '\"' |'\'' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j
| _ -> res.[!j] <- c; incr j
done;
- res;;
+ res
+;;
-let escape_char c = if c = '\'' then "\\'" else String.make 1 c;;
+let escape_char c = if c = '\'' then "\\\'" else String.make 1 c;;
let print_quoted_string s = printf "\"%s\"" (escape_string s);;
-let print_quoted_char c = printf "'%s'" (escape_char c);;
+let print_quoted_char c = printf "\'%s\'" (escape_char c);;
let print_quoted_int i =
- if i < 0 then printf "(%d)" i else printf "%d" i;;
+ if i < 0 then printf "(%d)" i else printf "%d" i
+;;
let print_quoted_float f =
- if f <= 0.0 then printf "(%f)" f else printf "%f" f;;
+ if f <= 0.0 then printf "(%f)" f else printf "%f" f
+;;
(* Iterators *)
let print_list f l =
- printf "@[<1>[";
- let rec pl = function
- | [] -> printf "@;<0 -1>]@]"
- | [x] -> f x; pl []
- | x :: xs -> f x; printf ";@ "; pl xs in
- pl l;;
+ printf "@[<1>[";
+ let rec pl = function
+ | [] -> printf "@;<0 -1>]@]"
+ | [x] -> f x; pl []
+ | x :: xs -> f x; printf ";@ "; pl xs in
+ pl l
+;;
let print_array f v =
- printf "@[<2>[|";
- let l = Array.length v in
- if l >= 1 then f v.(0);
- if l >= 2 then
- for i = 1 to l - 1 do
- printf ";@ "; f v.(i)
- done;
- printf "@;<0 -1>|]@]";;
+ printf "@[<2>[|";
+ let l = Array.length v in
+ if l >= 1 then f v.(0);
+ if l >= 2 then
+ for i = 1 to l - 1 do
+ printf ";@ "; f v.(i)
+ done;
+ printf "@;<0 -1>|]@]"
+;;
let print_option f = function
| None -> print_string "None"
- | Some x -> printf "@[<1>Some@ "; f x; printf "@]";;
+ | Some x -> printf "@[<1>Some@ "; f x; printf "@]"
+;;
let print_bool = function
- | true -> print_string "true" | _ -> print_string "false";;
+ | true -> print_string "true" | _ -> print_string "false"
+;;
let print_poly x = print_string "<poly>";;
printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]"
| As (m, s) ->
printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ ";
- print_quoted_string s; printf ")@]"; printf ")@]";;
+ print_quoted_string s; printf ")@]"; printf ")@]"
+;;
let rec print_template = function
| StringArg s ->
| OptionalArgs (s, l_t, l_t0) ->
printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>(";
print_quoted_string s; printf ",@ "; print_list print_template l_t;
- printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";;
+ printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]"
+;;
(* Sorts of components *)
let rec print_component_type = function
| Constructor -> printf "Constructor" | Command -> printf "Command"
- | External -> printf "External";;
+ | External -> printf "External"
+;;
(* Full definition of a component *)
let rec print_fullcomponent = function
printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0;
printf ";@]@ "; printf "@[<1>template =@ "; print_template t;
printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ ";
- printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";;
+ printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]"
+;;
(* components are given either in full or abbreviated *)
let rec print_component = function
| Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]"
| Abbrev s ->
- printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";;
+ printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]"
+;;
(* A type definition *)
(*
an additional argument of type Widget.
*)
let rec print_parser_arity = function
- | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";;
+ | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken"
+;;
let rec print_type_def = function
{parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f;
l_t_s_l_f;
printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b;
printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ ";
- printf "@,}@]";;
+ printf "@,}@]"
+;;
let rec print_module_type = function
- | Widget -> printf "Widget" | Family -> printf "Family";;
+ | Widget -> printf "Widget" | Family -> printf "Family"
+;;
let rec print_module_def = function
{module_type = m; commands = l_f; externals = l_f0; } ->
printf ";@]@ "; printf "@[<1>commands =@ ";
print_list print_fullcomponent l_f; printf ";@]@ ";
printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0;
- printf ";@]@ "; printf "@,}@]";;
+ printf ";@]@ "; printf "@,}@]"
+;;
(* *)
(***********************************************************************)
-(* $Id: tables.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
-open Support
(* Internal compiler errors *)
(* *)
(***********************************************************************)
-(* $Id: tsort.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include ../support/Makefile.common
# We are using the non-installed library !
-COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
+BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
+BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s
+
+WITH_BYT_CAMLTK=labltk.cma camltk.cmo
+WITH_BIN_CAMLTK=labltk.cmxa camltk.cmx
+
+BYT_EXECS =\
+ addition.byt helloworld.byt winskel.byt fileinput.byt\
+ eyes.byt taquin.byt tetris.byt mytext.byt fileopen.byt\
+
+BIN_EXECS=$(BYT_EXECS:.byt=.bin)
+
+EXECS=$(BYT_EXECS:.byt=$(EXE))
+
+all: byt bin
+
+byt: $(BYT_EXECS)
+
+#opt: hello.opt demo.opt calc.opt clock.opt tetris.opt
+
+bin: opt
+
+opt: $(BIN_EXECS)
+addition.bin: addition.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) addition.cmx
-all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \
- eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE)
+helloworld.bin: helloworld.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) helloworld.cmx
-addition$(EXE): addition.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo
+winskel.bin: winskel.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) winskel.cmx
-helloworld$(EXE): helloworld.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo
+fileinput.bin: fileinput.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) unix.cmxa fileinput.cmx
-winskel$(EXE): winskel.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo
+socketinput.bin: socketinput.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) socketinput.cmx
-fileinput$(EXE): fileinput.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo
+eyes.bin: eyes.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) eyes.cmx
-socketinput$(EXE): socketinput.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo
+taquin.bin: taquin.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) taquin.cmx
-eyes$(EXE): eyes.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo
+tetris.bin: tetris.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) tetris.cmx
-tetris$(EXE): tetris.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo
+mytext.bin: mytext.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) mytext.cmx
-mytext$(EXE): mytext.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo
+fileopen.bin: fileopen.cmx
+ $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) fileopen.cmx
-# graph$(EXE): graphics.cmo graphics_test.cmo
-# $(CAMLC) -o $@ graphics.cmo graphics_test.cmo
-#
-# graphics_test.cmo: graphics.cmo
-fileopen$(EXE): fileopen.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo
+addition.byt: addition.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo
+
+helloworld.byt: helloworld.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo
+
+winskel.byt: winskel.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo
+
+fileinput.byt: fileinput.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo
+
+socketinput.byt: socketinput.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo
+
+eyes.byt: eyes.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo
+
+taquin.byt: taquin.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma taquin.cmo
+
+tetris.byt: tetris.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo
+
+mytext.byt: mytext.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo
+
+fileopen.byt: fileopen.cmo
+ $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo
clean :
- rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel
+ rm -f *.cm? *.o a.out $(EXECS) $(BYT_EXECS) $(BIN_EXECS)
.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo
+.SUFFIXES : .mli .ml .cmi .cmo .cmx .cma .cmxa
.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
+ $(CAMLCOMP) $(BYT_COMPFLAGS) -c $<
.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
+ $(CAMLCOMP) $(BYT_COMPFLAGS) -c $<
+
+.ml.cmx:
+ $(CAMLOPT) $(BIN_COMPFLAGS) -c $<
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include ../support/Makefile.common
# We are using the non-installed library !
(* described in file LICENSE found in the OCaml source tree. *)
(* *)
(***********************************************************************)
-open Camltk
+
+open Camltk;;
let main () =
let top = opentk () in
mainLoop ()
;;
-let _ = Printexc.catch main () ;;
+Printexc.catch main ()
+;;
open Camltk;;
-let _ =
- let top = opentk () in
+let create_eye canvas cx cy wx wy ewx ewy bnd =
+ let _oval2 =
+ Canvas.create_oval canvas
+ (Pixels (cx - wx)) (Pixels (cy - wy))
+ (Pixels (cx + wx)) (Pixels (cy + wy))
+ [Outline (NamedColor "black"); Width (Pixels 7);
+ FillColor (NamedColor "white"); ]
+ and oval =
+ Canvas.create_oval canvas
+ (Pixels (cx - ewx)) (Pixels (cy - ewy))
+ (Pixels (cx + ewx)) (Pixels (cy + ewy))
+ [FillColor (NamedColor "black")] in
+ let curx = ref cx
+ and cury = ref cy in
+
+ let treat_event e =
+
+ let xdiff = e.ev_MouseX - cx
+ and ydiff = e.ev_MouseY - cy in
+
+ let diff =
+ sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
+ (float ydiff /. (float wy *. bnd)) ** 2.0) in
+
+ let nx, ny =
+ if diff <= 1.0 then e.ev_MouseX, e.ev_MouseY else
+ truncate ((float xdiff) *. (1.0 /. diff)) + cx,
+ truncate ((float ydiff) *. (1.0 /. diff)) + cy in
+
+ Canvas.move canvas oval (Pixels (nx - !curx)) (Pixels (ny - !cury));
+ curx := nx;
+ cury := ny; in
+
+ bind canvas [[], Motion] (
+ BindExtend ([Ev_MouseX; Ev_MouseY], treat_event)
+ )
+;;
+let main () =
+ let top = opentk () in
let fw = Frame.create top [] in
pack [fw] [];
- let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
- let create_eye cx cy wx wy ewx ewy bnd =
- let _o2 =
- Canvas.create_oval c
- (Pixels (cx - wx)) (Pixels (cy - wy))
- (Pixels (cx + wx)) (Pixels (cy + wy))
- [Outline (NamedColor "black"); Width (Pixels 7);
- FillColor (NamedColor "white")]
- and o =
- Canvas.create_oval c
- (Pixels (cx - ewx)) (Pixels (cy - ewy))
- (Pixels (cx + ewx)) (Pixels (cy + ewy))
- [FillColor (NamedColor "black")] in
- let curx = ref cx
- and cury = ref cy in
- bind c [[], Motion]
- (BindExtend ([Ev_MouseX; Ev_MouseY],
- (fun e ->
- let nx, ny =
- let xdiff = e.ev_MouseX - cx
- and ydiff = e.ev_MouseY - cy in
- let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
- (float ydiff /. (float wy *. bnd)) ** 2.0) in
- if diff > 1.0 then
- truncate ((float xdiff) *. (1.0 /. diff)) + cx,
- truncate ((float ydiff) *. (1.0 /. diff)) + cy
- else
- e.ev_MouseX, e.ev_MouseY
- in
- Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury));
- curx := nx;
- cury := ny)))
- in
- create_eye 60 100 30 40 5 6 0.6;
- create_eye 140 100 30 40 5 6 0.6;
- pack [c] []
-
-let _ = Printexc.print mainLoop ()
+
+ let canvas = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
+
+ create_eye canvas 60 100 30 40 5 6 0.6;
+ create_eye canvas 140 100 30 40 5 6 0.6;
+ pack [canvas] [];
+
+ mainLoop ();
+;;
+
+Printexc.print main ();;
+
(* described in file LICENSE found in the OCaml source tree. *)
(* *)
(***********************************************************************)
-open Camltk;; (* Make interface functions available *)
-let top = opentk ();; (* Initialisation of the interface *)
-(* top is now the toplevel widget *)
+(* Make interface functions available *)
+open Camltk;;
+
+(* Initialisation of the interface. *)
+let top = opentk ();;
+(* top is now the toplevel widget. *)
(* Widget initialisation *)
-let b = Button.create top
- [Text "foobar";
- Command (function () ->
- print_string "foobar";
- print_newline();
- flush stdout)];;
-(* b exists but is not yet visible *)
+let b =
+ Button.create top [
+ Text "foobar";
+ Command
+ (function () ->
+ print_string "foobar";
+ print_newline ();
+ flush stdout);
+ ]
+;;
+(* Now button [b] exists but is not yet visible. *)
+
+let q =
+ Button.create top [
+ Text "quit";
+ Command closeTk;
+ ]
+;;
+(* Button [q] also exists but is not yet visible. *)
-let q = Button.create top
- [Text "quit";
- Command closeTk];;
-(* q exists but is not yet visible *)
+(* Make b and q visible. *)
+pack [b; q] [];;
-pack [b; q][] ;; (* Make b visible *)
-mainLoop() ;; (* User interaction*)
-(* You can quit this program by deleting its main window *)
+(* Start user interaction. *)
+mainLoop ();;
+(* You can also quit this program by deleting its main window. *)
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Caml examples *)
+(* *)
+(* Pierre Weis *)
+(* *)
+(* INRIA Rocquencourt *)
+(* *)
+(* Copyright (c) 1994-2011, INRIA *)
+(* All rights reserved. *)
+(* *)
+(* Distributed under the BSD license. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: taquin.ml,v 1.4 2011-08-08 19:31:17 weis Exp $ *)
+
+open Camltk;;
+
+let découpe_image img nx ny =
+ let l = Imagephoto.width img
+ and h = Imagephoto.height img in
+ let tx = l / nx and ty = h / ny in
+ let pièces = ref [] in
+ for x = 0 to nx - 1 do
+ for y = 0 to ny - 1 do
+ let pièce =
+ Imagephoto.create [Width (Pixels tx); Height (Pixels ty)] in
+ Imagephoto.copy pièce img
+ [ImgFrom(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty)];
+ pièces := pièce :: !pièces
+ done
+ done;
+ (tx, ty, List.tl !pièces)
+;;
+
+let remplir_taquin c nx ny tx ty pièces =
+ let trou_x = ref (nx - 1)
+ and trou_y = ref (ny - 1) in
+ let trou =
+ Canvas.create_rectangle c
+ (Pixels (!trou_x * tx)) (Pixels (!trou_y * ty))
+ (Pixels tx) (Pixels ty) [] in
+ let taquin = Array.make_matrix nx ny trou in
+ let p = ref pièces in
+ for x = 0 to nx - 1 do
+ for y = 0 to ny - 1 do
+ match !p with
+ | [] -> ()
+ | pièce :: reste ->
+ taquin.(x).(y) <-
+ Canvas.create_image c
+ (Pixels (x * tx)) (Pixels (y * ty))
+ [ImagePhoto pièce; Anchor NW; Tags [Tag "pièce"]];
+ p := reste
+ done
+ done;
+ let déplacer x y =
+ let pièce = taquin.(x).(y) in
+ Canvas.coords_set c pièce
+ [Pixels (!trou_x * tx); Pixels(!trou_y * ty)];
+ Canvas.coords_set c trou
+ [Pixels (x * tx); Pixels(y * ty); Pixels tx; Pixels ty];
+ taquin.(!trou_x).(!trou_y) <- pièce;
+ taquin.(x).(y) <- trou;
+ trou_x := x; trou_y := y in
+ let jouer ei =
+ let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in
+ if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1)
+ || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1)
+ then déplacer x y in
+ Canvas.bind c (Tag "pièce") [[], ButtonPress]
+ (BindSet ([Ev_MouseX; Ev_MouseY], jouer));;
+
+let rec permutation = function
+ | [] -> []
+ | l -> let n = Random.int (List.length l) in
+ let (élément, reste) = partage l n in
+ élément :: permutation reste
+
+and partage l n =
+ match l with
+ | [] -> failwith "partage"
+ | tête :: reste ->
+ if n = 0 then (tête, reste) else
+ let (élément, reste') = partage reste (n - 1) in
+ (élément, tête :: reste')
+;;
+
+let create_filled_text parent lines =
+ let lnum = List.length lines
+ and lwidth =
+ List.fold_right
+ (fun line max ->
+ let l = String.length line in
+ if l > max then l else max)
+ lines 1 in
+ let txtw = Text.create parent [TextWidth lwidth; TextHeight lnum] in
+ List.iter
+ (fun line ->
+ Text.insert txtw (TextIndex (End, [])) line [];
+ Text.insert txtw (TextIndex (End, [])) "\n" [])
+ lines;
+ txtw
+;;
+
+let give_help parent lines () =
+ let help_window = Toplevel.create parent [] in
+ Wm.title_set help_window "Help";
+
+ let help_frame = Frame.create help_window [] in
+
+ let help_txtw = create_filled_text help_frame lines in
+
+ let quit_help () = destroy help_window in
+ let ok_button = Button.create help_frame [Text "Ok"; Command quit_help] in
+
+ pack [help_txtw; ok_button ] [Side Side_Bottom];
+ pack [help_frame] []
+;;
+
+let taquin nom_fichier nx ny =
+ let fp = openTk () in
+ Wm.title_set fp "Taquin";
+ let img = Imagephoto.create [File nom_fichier] in
+ let c =
+ Canvas.create fp
+ [Width(Pixels(Imagephoto.width img));
+ Height(Pixels(Imagephoto.height img))] in
+ let (tx, ty, pièces) = découpe_image img nx ny in
+ remplir_taquin c nx ny tx ty (permutation pièces);
+ pack [c] [];
+
+ let quit = Button.create fp [Text "Quit"; Command closeTk] in
+ let help_lines =
+ ["Pour jouer, cliquer sur une des pièces";
+ "entourant le trou";
+ "";
+ "To play, click on a part around the hole"] in
+ let help =
+ Button.create fp [Text "Help"; Command (give_help fp help_lines)] in
+ pack [quit; help] [Side Side_Left; Fill Fill_X];
+ mainLoop ()
+;;
+
+if !Sys.interactive then () else begin taquin "joconde.gif" 3 5; exit 0 end;;
(***********************************************************************)
(* *)
-(* MLTk, Tcl/Tk interface of OCaml *)
+(* Caml examples *)
(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
+(* Pierre Weis *)
(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the OCaml source tree. *)
+(* INRIA Rocquencourt *)
+(* *)
+(* Copyright (c) 1994-2011, INRIA *)
+(* All rights reserved. *)
+(* *)
+(* Distributed under the BSD license. *)
(* *)
(***********************************************************************)
-(* A Tetris game for CamlTk *)
-(* written by Jun P. Furuse *)
+(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *)
-open Camltk
+(* A Tetris game for CamlTk.
+ Written by Jun P. Furuse.
+ Adapted to the oc examples repository by P. Weis *)
-exception Done
+open Camltk;;
-type cell = {mutable color : int;
- tag : tagOrId * tagOrId * tagOrId}
+(* The directory where images will be found. *)
+let baseurl = "images/";;
+
+exception Done;;
+
+type cell = {
+ mutable color : int;
+ tag : tagOrId * tagOrId * tagOrId;
+}
+;;
type falling_block = {
- mutable pattern: int array list;
- mutable bcolor: int;
- mutable x: int;
- mutable y: int;
- mutable d: int;
- mutable alive: bool
+ mutable pattern : int array list;
+ mutable bcolor : int;
+ mutable x : int;
+ mutable y : int;
+ mutable d : int;
+ mutable alive: bool;
}
+;;
-let stop_a_bit = 300
+let stop_a_bit = 300;;
let colors = [|
- NamedColor "red";
- NamedColor "yellow";
-
- NamedColor "blue";
- NamedColor "orange";
-
- NamedColor "magenta";
- NamedColor "green";
-
- NamedColor "cyan"
+ NamedColor "red"; NamedColor "yellow"; NamedColor "blue";
+ NamedColor "orange"; NamedColor "magenta"; NamedColor "green";
+ NamedColor "cyan";
|]
-
-let baseurl = "images/"
+;;
let backgrounds =
List.map (fun s -> baseurl ^ s)
- [ "dojoji.back.gif";
- "Lambda2back.gif";
- "CamlBook.gif";
- ]
+ [ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];;
(* blocks *)
let block_size = 16
-let cell_border = 2
+and cell_border = 2
+;;
let blocks = [
- [ [|"0000";
- "0000";
- "1111";
- "0000" |];
-
- [|"0010";
- "0010";
- "0010";
- "0010" |];
-
- [|"0000";
- "0000";
- "1111";
- "0000" |];
-
- [|"0010";
- "0010";
- "0010";
- "0010" |] ];
-
- [ [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "0111";
- "0100";
- "0000" |];
-
- [|"0000";
- "0110";
- "0010";
- "0010" |];
-
- [|"0000";
- "0010";
- "1110";
- "0000" |];
-
- [|"0100";
- "0100";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "0100";
- "0111";
- "0000" |];
-
- [|"0000";
- "0110";
- "0100";
- "0100" |];
-
- [|"0000";
- "1110";
- "0010";
- "0000" |];
-
- [|"0010";
- "0010";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "1100";
- "0110";
- "0000" |];
-
- [|"0010";
- "0110";
- "0100";
- "0000" |];
-
- [|"0000";
- "1100";
- "0110";
- "0000" |];
-
- [|"0010";
- "0110";
- "0100";
- "0000" |] ];
-
- [ [|"0000";
- "0011";
- "0110";
- "0000" |];
-
- [|"0100";
- "0110";
- "0010";
- "0000" |];
-
- [|"0000";
- "0011";
- "0110";
- "0000" |];
-
- [|"0000";
- "0100";
- "0110";
- "0010" |] ];
-
- [ [|"0000";
- "0000";
- "1110";
- "0100" |];
-
- [|"0000";
- "0100";
- "1100";
- "0100" |];
-
- [|"0000";
- "0100";
- "1110";
- "0000" |];
-
- [|"0000";
- "0100";
- "0110";
- "0100" |] ]
-
+ [ [|"0000"; "0000"; "1111"; "0000" |];
+ [|"0010"; "0010"; "0010"; "0010" |];
+ [|"0000"; "0000"; "1111"; "0000" |];
+ [|"0010"; "0010"; "0010"; "0010" |] ];
+
+ [ [|"0000"; "0110"; "0110"; "0000" |];
+ [|"0000"; "0110"; "0110"; "0000" |];
+ [|"0000"; "0110"; "0110"; "0000" |];
+ [|"0000"; "0110"; "0110"; "0000" |] ];
+
+ [ [|"0000"; "0111"; "0100"; "0000" |];
+ [|"0000"; "0110"; "0010"; "0010" |];
+ [|"0000"; "0010"; "1110"; "0000" |];
+ [|"0100"; "0100"; "0110"; "0000" |] ];
+
+ [ [|"0000"; "0100"; "0111"; "0000" |];
+ [|"0000"; "0110"; "0100"; "0100" |];
+ [|"0000"; "1110"; "0010"; "0000" |];
+ [|"0010"; "0010"; "0110"; "0000" |] ];
+
+ [ [|"0000"; "1100"; "0110"; "0000" |];
+ [|"0010"; "0110"; "0100"; "0000" |];
+ [|"0000"; "1100"; "0110"; "0000" |];
+ [|"0010"; "0110"; "0100"; "0000" |] ];
+
+ [ [|"0000"; "0011"; "0110"; "0000" |];
+ [|"0100"; "0110"; "0010"; "0000" |];
+ [|"0000"; "0011"; "0110"; "0000" |];
+ [|"0000"; "0100"; "0110"; "0010" |] ];
+
+ [ [|"0000"; "0000"; "1110"; "0100" |];
+ [|"0000"; "0100"; "1100"; "0100" |];
+ [|"0000"; "0100"; "1110"; "0000" |];
+ [|"0000"; "0100"; "0110"; "0100" |] ];
]
+;;
let line_empty = int_of_string "0b1110000000000111"
-let line_full = int_of_string "0b1111111111111111"
+and line_full = int_of_string "0b1111111111111111"
+;;
let decode_block dvec =
- let btoi d = int_of_string ("0b"^d) in
+ let btoi d = int_of_string ("0b" ^ d) in
Array.map btoi dvec
+;;
let init fw =
let scorev = Textvariable.create ()
and linev = Textvariable.create ()
and levv = Textvariable.create ()
- in
+ and _namev = Textvariable.create () in
let f = Frame.create fw [BorderWidth (Pixels 2)] in
- let c = Canvas.create f [Width (Pixels (block_size * 10));
- Height (Pixels (block_size * 20));
- BorderWidth (Pixels cell_border);
- Relief Sunken;
- Background Black]
+ let c =
+ Canvas.create f
+ [Width (Pixels (block_size * 10));
+ Height (Pixels (block_size * 20));
+ BorderWidth (Pixels cell_border);
+ Relief Sunken;
+ Background Black]
and r = Frame.create f []
and r' = Frame.create f [] in
let nl = Label.create r [Text "Next"; Font "variable"] in
- let nc = Canvas.create r [Width (Pixels (block_size * 4));
- Height (Pixels (block_size * 4));
- BorderWidth (Pixels cell_border);
- Relief Sunken;
- Background Black] in
+ let nc =
+ Canvas.create r
+ [Width (Pixels (block_size * 4));
+ Height (Pixels (block_size * 4));
+ BorderWidth (Pixels cell_border);
+ Relief Sunken;
+ Background Black] in
let scl = Label.create r [Text "Score"; Font "variable"] in
let sc = Label.create r [TextVariable scorev; Font "variable"] in
let lnl = Label.create r [Text "Lines"; Font "variable"] in
pack [nl; nc] [Side Side_Top];
pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
- let cells_src = Array.create 20 (Array.create 10 ()) in
+ let cells_src = Array.make_matrix 20 10 () in
let cells = Array.map (Array.map (fun () ->
- {tag=
- (let t1, t2, t3 =
+ {tag =
+ (let t1, t2, t3 =
+ Canvas.create_rectangle c
+ (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+ (Pixels (-9)) (Pixels (-9)) [],
Canvas.create_rectangle c
- (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
- (Pixels (-9)) (Pixels (-9)) [],
+ (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+ (Pixels (-11)) (Pixels (-11)) [],
Canvas.create_rectangle c
- (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
- (Pixels (-11)) (Pixels (-11)) [],
- Canvas.create_rectangle c
- (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
- (Pixels (-13)) (Pixels (-13)) []
- in
- Canvas.raise_top c t1;
- Canvas.raise_top c t2;
- Canvas.lower_bot c t3;
- t1,t2,t3);
- color= 0})) cells_src
- in
- let nexts_src = Array.create 4 (Array.create 4 ()) in
+ (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+ (Pixels (-13)) (Pixels (-13)) [] in
+ Canvas.raise_top c t1;
+ Canvas.raise_top c t2;
+ Canvas.lower_bot c t3;
+ t1, t2, t3);
+ color = 0})) cells_src in
+ let nexts_src = Array.make_matrix 4 4 () in
let nexts =
Array.map (Array.map (fun () ->
- {tag=
- (let t1, t2, t3 =
- Canvas.create_rectangle nc
- (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
- (Pixels (-9)) (Pixels (-9)) [],
- Canvas.create_rectangle nc
- (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
- (Pixels (-11)) (Pixels (-11)) [],
- Canvas.create_rectangle nc
- (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
- (Pixels (-13)) (Pixels (-13)) []
- in
- Canvas.raise_top nc t1;
- Canvas.raise_top nc t2;
- Canvas.lower_bot nc t3;
- t1, t2, t3);
- color= 0})) nexts_src in
+ {tag =
+ (let t1, t2, t3 =
+ Canvas.create_rectangle nc
+ (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+ (Pixels (-9)) (Pixels (-9)) [],
+ Canvas.create_rectangle nc
+ (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+ (Pixels (-11)) (Pixels (-11)) [],
+ Canvas.create_rectangle nc
+ (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+ (Pixels (-13)) (Pixels (-13)) [] in
+ Canvas.raise_top nc t1;
+ Canvas.raise_top nc t2;
+ Canvas.lower_bot nc t3;
+ t1, t2, t3);
+ color = 0})) nexts_src in
let game_over () = ()
in
- [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
- (c, cells), (nc, nexts), scorev, linev, levv, game_over
+ [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
+ (c, cells), (nc, nexts), scorev, linev, levv, game_over
+;;
-let cell_get (c, cf) x y =
- (Array.get (Array.get cf y) x).color
+let cell_get (c, cf) x y = cf.(y).(x).color;;
let cell_set (c, cf) x y col =
- let cur = Array.get (Array.get cf y) x in
- let t1,t2,t3 = cur.tag in
- if cur.color = col then ()
- else
- if cur.color <> 0 && col = 0 then
- begin
+ let cur = cf.(y).(x) in
+ let t1, t2, t3 = cur.tag in
+ if cur.color = col then () else
+ if cur.color <> 0 && col = 0 then begin
+ Canvas.move c t1
+ (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+ (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+ Canvas.move c t2
+ (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+ (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+ Canvas.move c t3
+ (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+ (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
+
+ end else begin
+ Canvas.configure_rectangle c t2
+ [FillColor (Array.get colors (col - 1));
+ Outline (Array.get colors (col - 1))];
+ Canvas.configure_rectangle c t1
+ [FillColor Black;
+ Outline Black];
+ Canvas.configure_rectangle c t3
+ [FillColor (NamedColor "light gray");
+ Outline (NamedColor "light gray")];
+ if cur.color = 0 && col <> 0 then begin
Canvas.move c t1
- (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
- (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+ (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+ (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
Canvas.move c t2
- (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
- (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+ (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+ (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
Canvas.move c t3
- (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
- (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
- end
- else
- begin
- Canvas.configure_rectangle c t2
- [FillColor (Array.get colors (col - 1));
- Outline (Array.get colors (col - 1))];
- Canvas.configure_rectangle c t1
- [FillColor Black;
- Outline Black];
- Canvas.configure_rectangle c t3
- [FillColor (NamedColor "light gray");
- Outline (NamedColor "light gray")];
- if cur.color = 0 && col <> 0 then
- begin
- Canvas.move c t1
- (Pixels (block_size * (x+1)+10+ cell_border*2))
- (Pixels (block_size * (y+1)+10+ cell_border*2));
- Canvas.move c t2
- (Pixels (block_size * (x+1)+10+ cell_border*2))
- (Pixels (block_size * (y+1)+10+ cell_border*2));
- Canvas.move c t3
- (Pixels (block_size * (x+1)+10+ cell_border*2))
- (Pixels (block_size * (y+1)+10+ cell_border*2))
- end
- end;
- cur.color <- col
+ (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+ (Pixels (block_size * (y + 1) + 10 + cell_border * 2))
+ end
+ end;
+ cur.color <- col
+;;
let draw_block field col d x y =
for iy = 0 to 3 do
let base = ref 1 in
let xd = Array.get d iy in
for ix = 0 to 3 do
- if xd land !base <> 0 then
- begin
- try cell_set field (ix + x) (iy + y) col with _ -> ()
- end
- else
- begin
- (* cell_set field (ix + x) (iy + y) 0 *) ()
- end;
+ if xd land !base <> 0 then begin
+ try cell_set field (ix + x) (iy + y) col with _ -> ()
+ end;
base := !base lsl 1
done
done
+;;
-let timer_ref = (ref None : Timer.t option ref)
-(* I know, this should be timer ref, but I'm not sure what should be
- the initial value ... *)
+let timer_ref = (ref None : Timer.t option ref);;
let remove_timer () =
match !timer_ref with
| None -> ()
- | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
+ | Some t -> Timer.remove t
+;;
-let do_after milli f =
- timer_ref := Some (Timer.add milli f)
+let do_after milli f = timer_ref := Some (Timer.add milli f);;
let copy_block c =
- { pattern= !c.pattern;
- bcolor= !c.bcolor;
- x= !c.x;
- y= !c.y;
- d= !c.d;
- alive= !c.alive }
-
-let _ =
- let top = opentk () in
+ { pattern = !c.pattern;
+ bcolor = !c.bcolor;
+ x = !c.x;
+ y = !c.y;
+ d = !c.d;
+ alive = !c.alive }
+;;
+
+let start_game () =
+ let top = openTk () in
+ Wm.title_set top "";
let lb = Label.create top []
- and fw = Frame.create top []
- in
+ and fw = Frame.create top [] in
let set_message s = Label.configure lb [Text s] in
pack [lb; fw] [Side Side_Top];
let score = ref 0 in
let level = ref 0 in
let time = ref 1000 in
let blocks = List.map (List.map decode_block) blocks in
- let field = Array.create 26 0 in
+ let field = Array.make 26 0 in
let widgets, newg, exitg, cell_field, next_field,
- scorev, linev, levv, game_over =
- init fw in
+ scorev, linev, levv, game_over = init fw in
let canvas = fst cell_field in
let init_field () =
for j = 0 to 3 do
cell_set next_field j i 0
done
- done
- in
+ done in
let draw_falling_block fb =
draw_block cell_field fb.bcolor
(List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
-
and erase_falling_block fb =
- draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
- in
+ draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in
let stone fb =
- for i=0 to 3 do
+ for i = 0 to 3 do
let cur = field.(i + fb.y) in
field.(i + fb.y) <-
cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
done;
- for i=0 to 2 do
- field.(i) <- line_empty
- done
+ for i = 0 to 2 do field.(i) <- line_empty done
and clear fb =
let l = ref 0 in
for i = 0 to 3 do
- if i + fb.y >= 3 && i + fb.y <= 22 then
- if field.(i + fb.y) = line_full then
- begin
- incr l;
- field.(i + fb.y) <- line_empty;
- for j = 0 to 9 do
- cell_set cell_field j (i + fb.y - 3) 0
- done
- end
+ if i + fb.y >= 3 && i + fb.y <= 22 &&
+ field.(i + fb.y) = line_full then begin
+ incr l;
+ field.(i + fb.y) <- line_empty;
+ for j = 0 to 9 do cell_set cell_field j (i + fb.y - 3) 0 done
+ end
done;
!l
and fall_lines () =
let eye = ref 22 (* bottom *)
- and cur = ref 22 (* bottom *)
- in
+ and cur = ref 22 (* bottom *) in
try
while !eye >= 3 do
while field.(!eye) = line_empty do
with Done -> ();
for i = 3 to !cur do
field.(i) <- line_empty;
- for j = 0 to 9 do
- cell_set cell_field j (i-3) 0
- done
- done
- in
+ for j = 0 to 9 do cell_set cell_field j (i - 3) 0 done
+ done in
let next = ref 42 (* THE ANSWER *)
and current =
- ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false}
- in
+ ref { pattern= [[|0; 0; 0; 0|]];
+ bcolor = 0; x = 0; y = 0; d = 0; alive = false} in
let draw_next () =
- draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0
+ draw_block next_field (!next + 1) (List.hd (List.nth blocks !next)) 0 0
and erase_next () =
- draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0
- in
+ draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in
let set_nextblock () =
current :=
- { pattern= (List.nth blocks !next);
- bcolor= !next+1;
- x=6; y= 1; d= 0; alive= true};
+ { pattern = (List.nth blocks !next);
+ bcolor = !next + 1;
+ x = 6; y = 1; d = 0; alive = true};
erase_next ();
next := Random.int 7;
- draw_next ()
- in
+ draw_next () in
let death_check fb =
try
done;
false
with
- Done -> true
- in
+ Done -> true in
let try_to_move m =
if !current.alive then
draw_falling_block m;
current := m;
true
- end
- in
- if sub m then ()
- else
- begin
- m.x <- m.x + 1;
- if sub m then ()
- else
- begin
- m.x <- m.x - 2;
- ignore (sub m)
- end
+ end in
+ if sub m then () else begin
+ m.x <- m.x + 1;
+ if sub m then () else begin
+ m.x <- m.x - 2;
+ ignore (sub m)
end
- else ()
- in
+ end
+ else () in
let image_load =
- let i = Canvas.create_image canvas
- (Pixels (block_size * 5 + block_size / 2))
- (Pixels (block_size * 10 + block_size / 2))
- [Anchor Center] in
+ let i =
+ Canvas.create_image canvas
+ (Pixels (block_size * 5 + block_size / 2))
+ (Pixels (block_size * 10 + block_size / 2))
+ [Anchor Center] in
Canvas.lower_bot canvas i;
let img = Imagephoto.create [] in
fun file ->
try
Imagephoto.configure img [File file];
Canvas.configure_image canvas i [ImagePhoto img]
- with
- _ ->
- begin
- Printf.eprintf "%s : No such image...\n" file;
- flush stderr
- end
- in
+ with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr in
let add_score l =
let pline = !line in
Textvariable.set linev (string_of_int !line);
Textvariable.set scorev (string_of_int !score);
- if !line /10 <> pline /10 then
+ if !line / 10 <> pline / 10 then
(* update the background every 10 lines. *)
begin
let num_image = List.length backgrounds - 1 in
- let n = !line/10 in
+ let n = !line / 10 in
let n = if n > num_image then num_image else n in
let file = List.nth backgrounds n in
image_load file;
(* Future work: We should gain level after an image is put... *)
incr level;
Textvariable.set levv (string_of_int !level)
- end
- in
+ end in
let rec newblock () =
set_message "TETRIS";
set_nextblock ();
draw_falling_block !current;
- if death_check !current then
- begin
+ if death_check !current then begin
!current.alive <- false;
set_message "GAME OVER";
game_over ()
- end
- else
- begin
- time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
- if !time < 60 - !level * 3 then time := 60 - !level * 3;
- do_after stop_a_bit loop
- end
+ end else begin
+ time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
+ if !time < 60 - !level * 3 then time := 60 - !level * 3;
+ do_after stop_a_bit loop
+ end
and loop () =
let m = copy_block current in
m.y <- m.y + 1;
- if death_check m then
- begin
- !current.alive <- false;
- stone !current;
- do_after stop_a_bit (fun () ->
- let l = clear !current in
- if l > 0 then
- do_after stop_a_bit (fun () ->
- fall_lines ();
- add_score l;
- do_after stop_a_bit newblock)
- else
- newblock ())
- end
- else
- begin
- erase_falling_block !current;
- draw_falling_block m;
- current := m;
- do_after !time loop
- end
- in
+ if death_check m then begin
+ !current.alive <- false;
+ stone !current;
+ do_after stop_a_bit (fun () ->
+ let l = clear !current in
+ if l > 0 then
+ do_after stop_a_bit (fun () ->
+ fall_lines ();
+ add_score l;
+ do_after stop_a_bit newblock)
+ else newblock ())
+ end else begin
+ erase_falling_block !current;
+ draw_falling_block m;
+ current := m;
+ do_after !time loop
+ end in
let bind_game w =
bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
loop ()
end
| _ -> ()
- ))
- in
+ )) in
let game_init () =
(* Game Initialization *)
set_message "Welcome to TETRIS";
set_nextblock ();
draw_falling_block !current;
- do_after !time loop
- in
- bind_game top;
- Button.configure newg [Command game_init];
- Button.configure exitg [Command (fun () -> closeTk (); exit 0)];
- game_init ()
+ do_after !time loop in
+
+ bind_game top;
+ Button.configure newg [Command game_init];
+ Button.configure exitg [Command (fun () -> exit 0)];
+ game_init ()
+;;
+
+let tetris () =
+ start_game ();
+ Printexc.print mainLoop ()
+;;
-let _ = Printexc.print mainLoop ()
+if !Sys.interactive then () else begin tetris (); exit 0 end;;
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include ../support/Makefile.common
COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include ../support/Makefile.common
# We are using the non-installed library !
-$Id: README 4745 2002-04-26 12:16:26Z furuse $
+$Id$
Some examples for LablTk.
They are written in classic mode, except testris.ml which uses label
(* *)
(***********************************************************************)
-(* $Id: calc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* A simple calculator demonstrating OO programming with O'Labl
and LablTk.
(* *)
(***********************************************************************)
-(* $Id: clock.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Clock/V, a simple clock.
Reverts every time you push the right button.
(* *)
(***********************************************************************)
-(* $Id: demo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Some CamlTk4 Demonstration by JPF *)
(* *)
(***********************************************************************)
-(* $Id: eyes.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
pack [fw];
let c = Canvas.create ~width: 200 ~height: 200 fw in
let create_eye cx cy wx wy ewx ewy bnd =
- let o2 = Canvas.create_oval
+ let _o2 = Canvas.create_oval
~x1:(cx - wx) ~y1:(cy - wy)
~x2:(cx + wx) ~y2:(cy + wy)
~outline: `Black ~width: 7
(* *)
(***********************************************************************)
-(* $Id: hello.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* LablTk4 Demonstration by JPF *)
#!/usr/bin/wish
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
button .hello -text "Hello, TclTk!"
pack .hello
(* *)
(***********************************************************************)
-(* $Id: taquin.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk;;
(* *)
(***********************************************************************)
-(* $Id: tetris.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* A Tetris game for LablTk *)
(* written by Jun P. Furuse *)
let scorev = Textvariable.create ()
and linev = Textvariable.create ()
and levv = Textvariable.create ()
- and namev = Textvariable.create ()
in
let f = Frame.create fw ~borderwidth: 2 in
let c = Canvas.create f ~width: (block_size * 10)
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
(***********************************************************************)
open Camltk
-let version = "$Id: frx_entry.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* Tk 4.0 has emacs bindings for entry widgets
(***********************************************************************)
open Camltk
-let version = "$Id: frx_fileinput.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* Simple spooling for fileinput callbacks
open Camltk
open Widget
-let version = "$Id: frx_font.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* Finding fonts. Inspired by code in Ical by Sanjay Ghemawat.
open Widget
-let version = "$Id: frx_lbutton.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* Simulate a button with a bitmap AND a label
(***********************************************************************)
open Camltk
-let version = "$Id: frx_listbox.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* Link a scrollbar and a listbox
* jargon).
*)
-let version = "$Id: frx_req.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* Simple requester
(***********************************************************************)
open Camltk
-let version = "$Id: frx_text.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(*
* convert an integer to an absolute index
open Camltk
open Widget
-let version = "$Id: frx_widget.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
(* Make a window (toplevel widget) resizeable *)
let resizeable t =
update_idletasks(); (* wait until layout is computed *)
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
(* *)
(***********************************************************************)
-(* $Id: balloon.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open StdLabels
(* *)
(***********************************************************************)
-(* $Id: balloon.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* easy balloon help facility *)
open Widget
(* *)
(***********************************************************************)
-(* $Id: balloontest.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Tk
open Widget
(* *)
(***********************************************************************)
-(* $Id: fileselect.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* file selection box *)
(* *)
(***********************************************************************)
-(* $Id: fileselect.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* This file selecter works only under the OS with the full unix support.
For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile.gen
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
-WIDGETOBJS=bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo
+WIDGETOBJS= bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo
bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml
bell.cmo : bell.ml
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
include Makefile
/* */
/*************************************************************************/
-/* $Id: camltk.h 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
#if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT)
#define CAMLTKextern CAMLexport
#define CONST84
#endif
+/*Tcl_GetResult(), Tcl_GetStringResult(), Tcl_SetResult(), */
+ /*Tcl_SetStringResult(), Tcl_GetErrorLine() */
+
/* if Tcl_GetStringResult is not defined, we use interp->result */
-#ifndef Tcl_GetStringResult
-# define Tcl_GetStringResult(interp) (interp->result)
-#endif
+/*#ifndef Tcl_GetStringResult*/
+/*# define Tcl_GetStringResult(interp) (interp->result)*/
+/*#endif*/
/* cltkMisc.c */
/* copy an OCaml string to the C heap. Must be deallocated with stat_free */
/* */
/***********************************************************************/
-/* $Id: cltkCaml.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
#include <tcl.h>
#include <tk.h>
/* */
/*************************************************************************/
-/* $Id: cltkDMain.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
#include <unistd.h>
#include <fcntl.h>
+ trail.symbol_size + trail.debug_size), 2);
code_size = trail.code_size;
- start_code = (code_t) stat_alloc(code_size);
+ start_code = (code_t) caml_stat_alloc(code_size);
if (read(fd, (char *) start_code, code_size) != code_size)
fatal_error("Fatal error: truncated bytecode file.\n");
{
char *home = getenv("HOME");
if (home != NULL) {
- char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
+ char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2);
f[0]='\0';
strcat(f, home);
strcat(f, "/");
/* */
/***********************************************************************/
-/* $Id: cltkEval.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
#include <stdlib.h>
#include <string.h>
char *merged;
int i;
int size = argv_size(Field(v,0));
- tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
+ tmpargv = (char **)caml_stat_alloc((size + 1) * sizeof(char *));
fill_args(tmpargv,0,Field(v,0));
tmpargv[size] = NULL;
merged = Tcl_Merge(size,(const char *const*)tmpargv);
for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
stat_free((char *)tmpargv);
/* must be freed by stat_free */
- argv[where] = (char*)stat_alloc(strlen(merged)+1);
+ argv[where] = (char*)caml_stat_alloc(strlen(merged)+1);
strcpy(argv[where], merged);
Tcl_Free(merged);
return (where + 1);
/* +2: one slot for NULL
one slot for "unknown" if command not found */
- argv = (char **)stat_alloc((size + 2) * sizeof(char *));
- allocated = (char **)stat_alloc(size * sizeof(char *));
+ argv = (char **)caml_stat_alloc((size + 2) * sizeof(char *));
+ allocated = (char **)caml_stat_alloc(size * sizeof(char *));
/* Copy -- argv[i] must be freed by stat_free */
{
/* */
/***********************************************************************/
-/* $Id: cltkEvent.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
#include <tcl.h>
#include <tk.h>
/* */
/***********************************************************************/
-/* $Id: cltkFile.c 12716 2012-07-16 20:01:36Z doligez $ */
+/* $Id$ */
#ifdef _WIN32
#include <wtypes.h>
/* */
/***********************************************************************/
-/* $Id: cltkMain.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
#include <string.h>
#include <tcl.h>
char **tkargv;
char argcstr[256]; /* string of argc */
- tkargv = (char**)stat_alloc(sizeof( char* ) * argc );
+ tkargv = (char**)caml_stat_alloc(sizeof( char* ) * argc );
tmp = Field(argv, 1); /* starts from argv[1] */
i = 0;
{
char *home = getenv("HOME");
if (home != NULL) {
- char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
+ char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2);
f[0]='\0';
strcat(f, home);
strcat(f, "/");
/* */
/***********************************************************************/
-/* $Id: cltkMisc.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
#include <string.h>
#include <tcl.h>
char *string_to_c(value s)
{
int l = string_length(s);
- char *res = stat_alloc(l + 1);
+ char *res = caml_stat_alloc(l + 1);
memmove (res, String_val (s), l);
res[l] = '\0';
return res;
/* */
/***********************************************************************/
-/* $Id: cltkTimer.c 12126 2012-02-05 09:20:46Z bmeurer $ */
+/* $Id$ */
#include <tcl.h>
#include <tk.h>
/* */
/***********************************************************************/
-/* $Id: cltkUtf.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
#include <stdlib.h>
#include <string.h>
Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr);
length = Tcl_DStringLength(&dstr);
- res = stat_alloc(length + 1);
+ res = caml_stat_alloc(length + 1);
memmove( res, Tcl_DStringValue(&dstr), length+1);
Tcl_DStringFree(&dstr);
Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr);
length = Tcl_DStringLength(&dstr);
- res = stat_alloc(length + 1);
+ res = caml_stat_alloc(length + 1);
memmove( res, Tcl_DStringValue(&dstr), length+1);
Tcl_DStringFree(&dstr);
/* */
/***********************************************************************/
-/* $Id: cltkVar.c 12800 2012-07-30 18:59:07Z doligez $ */
+/* $Id$ */
/* Alternative to tkwait variable */
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: cltkWait.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
#include <tcl.h>
#include <tk.h>
CAMLprim value camltk_wait_vis(value win, value cbid)
{
struct WinCBData *vis =
- (struct WinCBData *)stat_alloc(sizeof(struct WinCBData));
+ (struct WinCBData *)caml_stat_alloc(sizeof(struct WinCBData));
vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
if (vis -> win == NULL) {
stat_free((char *)vis);
CAMLprim value camltk_wait_des(value win, value cbid)
{
struct WinCBData *vis =
- (struct WinCBData *)stat_alloc(sizeof(struct WinCBData));
+ (struct WinCBData *)caml_stat_alloc(sizeof(struct WinCBData));
vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
if (vis -> win == NULL) {
stat_free((char *)vis);
(* *)
(***********************************************************************)
-(* $Id: fileevent.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Unix
-open Support
open Protocol
external add_file_input : file_descr -> cbid -> unit
(* *)
(***********************************************************************)
-(* $Id: fileevent.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Unix
(* *)
(***********************************************************************)
-(* $Id: protocol.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
-open Support
open Widget
type callback_buffer = string list
(* *)
(***********************************************************************)
-(* $Id: protocol.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Widget
(* *)
(***********************************************************************)
-(* $Id: rawwidget.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-open Support
+(* $Id$ *)
(*
* Widgets
(* *)
(***********************************************************************)
-(* $Id: rawwidget.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Support for widget manipulations *)
(* *)
(***********************************************************************)
-(* $Id: slave.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* The code run on initialisation, in addition to normal Tk code
* NOTE: camltk has not fully been initialised yet
(* *)
(***********************************************************************)
-(* $Id: support.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Parsing results of Tcl *)
(* List.split a string according to char_sep predicate *)
(* *)
(***********************************************************************)
-(* $Id: support.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val split_str : pred:(char -> bool) -> string -> string list
val may : ('a -> 'b) -> 'a option -> 'b option
(* *)
(***********************************************************************)
-(* $Id: textvariable.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
-open Support
open Protocol
external internal_tracevar : string -> cbid -> unit
(* *)
(***********************************************************************)
-(* $Id: textvariable.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Support for Tk -textvariable option *)
open Widget
(* *)
(***********************************************************************)
-(* $Id: timer.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Timers *)
-open Support
open Protocol
type tkTimer = int
(* *)
(***********************************************************************)
-(* $Id: timer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
type t
(* *)
(***********************************************************************)
-(* $Id: tkthread.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
let jobs : (unit -> unit) Queue.t = Queue.create ()
let m = Mutex.create ()
(* *)
(***********************************************************************)
-(* $Id: tkthread.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Helper functions for using LablTk with threads.
To use, add tkthread.cmo or tkthread.cmx to your command line *)
(* *)
(***********************************************************************)
-(* $Id: tkwait.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
external internal_tracevis : string -> Protocol.cbid -> unit
= "camltk_wait_vis"
(* *)
(***********************************************************************)
-(* $Id: widget.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Hack to permit having the different data type with the same name
[widget] for CamlTk and LablTk. *)
(* *)
(***********************************************************************)
-(* $Id: widget.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Support for widget manipulations *)
# #
#########################################################################
-# $Id: Makefile 11886 2011-12-18 09:52:52Z xleroy $
+# $Id$
# Makefile for the "num" (exact rational arithmetic) library
# #
#########################################################################
-# $Id: Makefile.nt 11927 2011-12-21 16:31:01Z xleroy $
+# $Id$
# Makefile for the "num" (exact rational arithmetic) library
(* *)
(***********************************************************************)
-(* $Id: arith_flags.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
let error_when_null_denominator_flag = ref true;;
(* *)
(***********************************************************************)
-(* $Id: arith_flags.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
val error_when_null_denominator_flag : bool ref
val normalize_ratio_flag : bool ref
(* *)
(***********************************************************************)
-(* $Id: arith_status.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Arith_flags;;
(* *)
(***********************************************************************)
-(* $Id: arith_status.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(** Flags that control rational arithmetic. *)
(* *)
(***********************************************************************)
-(* $Id: big_int.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Int_misc
open Nat
let res = make_nat n
and res2 = make_nat (succ n)
and l = num_bits_int n - 2 in
- let p = ref (1 lsl l) in
blit_nat res 0 power_base pmax 1;
for i = l downto 0 do
let len = num_digits_nat res 0 n in
let succ_len2 = succ len2 in
ignore (square_nat res2 0 len2 res 0 len);
begin
- if n land !p > 0
+ if n land (1 lsl i) > 0
then (set_to_zero_nat res 0 len;
ignore (mult_digit_nat res 0 succ_len2
res2 0 len2 power_base pmax))
else blit_nat res 0 res2 0 len2
end;
- set_to_zero_nat res2 0 len2;
- p := !p lsr 1
+ set_to_zero_nat res2 0 len2
done;
if rem > 0
then (ignore (mult_digit_nat res2 0 (succ n)
let res = make_nat res_len
and res2 = make_nat res_len
and l = num_bits_int n - 2 in
- let p = ref (1 lsl l) in
blit_nat res 0 bi.abs_value 0 bi_len;
for i = l downto 0 do
let len = num_digits_nat res 0 res_len in
let len2 = min res_len (2 * len) in
set_to_zero_nat res2 0 len2;
ignore (square_nat res2 0 len2 res 0 len);
- if n land !p > 0 then begin
+ if n land (1 lsl i) > 0 then begin
let lenp = min res_len (len2 + bi_len) in
set_to_zero_nat res 0 lenp;
ignore(mult_nat res 0 lenp res2 0 len2 (bi.abs_value) 0 bi_len)
end else begin
blit_nat res 0 res2 0 len2
- end;
- p := !p lsr 1
+ end
done;
{sign = if bi.sign >= 0 then bi.sign
else if n land 1 = 0 then 1 else -1;
if bi.sign < 0 then begin
(* Two's complement *)
complement_nat res 0 size_res;
- ignore (incr_nat res 0 size_res 1)
+ (* PR#6010: need to increment res iff digits 0...ndigits-1 of bi are 0.
+ In this case, digits 0...ndigits-1 of not(bi) are all 0xFF...FF,
+ and adding 1 to them produces a carry out at ndigits. *)
+ let rec carry_incr i =
+ i >= ndigits || i >= size_bi ||
+ (is_digit_zero bi.abs_value i && carry_incr (i + 1)) in
+ if carry_incr 0 then ignore (incr_nat res 0 size_res 1)
end;
if nbits > 0 then begin
let tmp = create_nat 1 in
(* *)
(***********************************************************************)
-(* $Id: big_int.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(** Operations on arbitrary-precision integers.
(** {6 Bit-oriented operations} *)
val and_big_int : big_int -> big_int -> big_int
- (** Bitwise logical ``and''.
+ (** Bitwise logical 'and'.
The arguments must be positive or zero. *)
val or_big_int : big_int -> big_int -> big_int
- (** Bitwise logical ``or''.
+ (** Bitwise logical 'or'.
The arguments must be positive or zero. *)
val xor_big_int : big_int -> big_int -> big_int
- (** Bitwise logical ``exclusive or''.
+ (** Bitwise logical 'exclusive or'.
The arguments must be positive or zero. *)
val shift_left_big_int : big_int -> int -> big_int
(** [shift_left_big_int b n] returns [b] shifted left by [n] bits.
/* */
/***********************************************************************/
-/* $Id: bng.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
#include "bng.h"
#include "config.h"
/* */
/***********************************************************************/
-/* $Id: bng.h 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
#include <string.h>
#include "config.h"
/* */
/***********************************************************************/
-/* $Id: bng_amd64.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
/* Code specific to the AMD x86_64 architecture. */
/* */
/***********************************************************************/
-/* $Id: bng_digit.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
/**** Generic operations on digits ****/
/* */
/***********************************************************************/
-/* $Id: bng_ia32.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
/* Code specific to the Intel IA32 (x86) architecture. */
/* */
/***********************************************************************/
-/* $Id: bng_ppc.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
/* Code specific to the PowerPC architecture. */
/* */
/***********************************************************************/
-/* $Id: bng_sparc.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
/* Code specific to the SPARC (V8 and above) architecture. */
(* *)
(***********************************************************************)
-(* $Id: int_misc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Some extra operations on integers *)
(* *)
(***********************************************************************)
-(* $Id: int_misc.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Some extra operations on integers *)
/* */
/***********************************************************************/
-/* $Id: nat.h 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
/* Nats are represented as unstructured blocks with tag Custom_tag. */
(* *)
(***********************************************************************)
-(* $Id: nat.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Int_misc
(* XL: suppression de adjust_string *)
let power_base_int base i =
- if i = 0 then
+ if i = 0 || base = 1 then
nat_of_int 1
+ else if base = 0 then
+ nat_of_int 0
else if i < 0 then
invalid_arg "power_base_int"
else begin
let res = make_nat newn
and res2 = make_nat newn
and l = num_bits_int n - 2 in
- let p = ref (1 lsl l) in
blit_nat res 0 power_base pmax 1;
for i = l downto 0 do
let len = num_digits_nat res 0 newn in
let len2 = min n (2 * len) in
let succ_len2 = succ len2 in
ignore (square_nat res2 0 len2 res 0 len);
- if n land !p > 0 then begin
+ if n land (1 lsl i) > 0 then begin
set_to_zero_nat res 0 len;
ignore
(mult_digit_nat res 0 succ_len2
res2 0 len2 power_base pmax)
end else
blit_nat res 0 res2 0 len2;
- set_to_zero_nat res2 0 len2;
- p := !p lsr 1
+ set_to_zero_nat res2 0 len2
done;
if rem > 0 then begin
ignore
(* *)
(***********************************************************************)
-(* $Id: nat.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
(* Module [Nat]: operations on natural numbers *)
/* */
/***********************************************************************/
-/* $Id: nat_stubs.c 12800 2012-07-30 18:59:07Z doligez $ */
+/* $Id$ */
#include "alloc.h"
#include "config.h"
(* *)
(***********************************************************************)
-(* $Id: num.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
open Int_misc
open Nat
(* *)
(***********************************************************************)
-(* $Id: num.mli 12031 2012-01-17 20:32:33Z lefessan $ *)
+(* $Id$ *)
(** Operation on arbitrary-precision numbers.
(* *)
(***********************************************************************)
-(* $Id: ratio.mli 12301 2012-03-31 22:10:34Z doligez $ *)
+(* $Id$ *)
(** Operation on rational numbers.
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the str library
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the str library
LIBNAME=str
(* *)
(***********************************************************************)
-(* $Id: str.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** String utilities *)
let string_before s n = String.sub s 0 n
for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done;
t
-module StringMap = Map.Make(struct type t = string let compare = compare end)
+module StringMap =
+ Map.Make(struct type t = string let compare (x:t) y = compare x y end)
(* Compilation of a regular expression *)
(* *)
(***********************************************************************)
-(* $Id: str.mli 12922 2012-09-11 14:40:43Z doligez $ *)
-
(** Regular expressions and high-level string processing *)
- [\b ] Matches word boundaries.
- [\ ] Quotes special characters. The special characters
are [$^\.*+?[]].
+
+ Note: the argument to [regexp] is usually a string literal. In this
+ case, any backslash character in the regular expression must be
+ doubled to make it past the OCaml string parser. For example, the
+ following expression:
+ {[ let r = Str.regexp "hello \\([A-Za-z]+\\)" in
+ Str.replace_first r "\\1" "hello world" ]}
+ returns the string ["world"].
+
+ In particular, if you want a regular expression that matches a single
+ backslash character, you need to quote it in the argument to [regexp]
+ (according to the last item of the list above) by adding a second
+ backslash. Then you need to quote both backslashes (according to the
+ syntax of string constants in OCaml) by doubling them again, so you
+ need to write four backslash characters: [Str.regexp "\\\\"].
*)
val regexp_case_fold : string -> regexp
/* */
/***********************************************************************/
-/* $Id: strstubs.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <ctype.h>
#include <mlvalues.h>
/* Push an item on the backtrack stack and continue with next instr */
if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) {
struct backtrack_stack * newstack =
- stat_alloc(sizeof(struct backtrack_stack));
+ caml_stat_alloc(sizeof(struct backtrack_stack));
newstack->previous = stack;
stack = newstack;
sp = stack->point;
# #
#########################################################################
-# $Id: Makefile 12585 2012-06-08 11:35:37Z xleroy $
-
include ../../config/Makefile
CAMLC=../../ocamlcomp.sh -I ../unix
CAMLOPT=../../ocamlcompopt.sh -I ../unix
MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A -g
+COMPFLAGS=-w +33..39 -warn-error A -g
BYTECODE_C_OBJS=st_stubs_b.o
NATIVECODE_C_OBJS=st_stubs_n.o
$(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS)
st_stubs_n.o: st_stubs.c st_posix.h
- $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -c st_stubs.c
+ $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) \
+ $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) \
+ -DSYS_$(SYSTEM) -c st_stubs.c
mv st_stubs.o st_stubs_n.o
threads.cma: $(THREAD_OBJS)
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
include ../../config/Makefile
# Compilation options
CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix
CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix
-COMPFLAGS=-warn-error A -g
+COMPFLAGS=-w +33 -warn-error A -g
MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
CFLAGS=-I../../byterun $(EXTRACFLAGS)
allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES)
$(LIBNAME).cma: $(CAMLOBJS)
- $(MKLIB) -o $(LIBNAME) -ocamlc "..\\..\\boot\\ocamlrun ..\\..\\ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS)
+ $(MKLIB) -o $(LIBNAME) -ocamlc "../../boot/ocamlrun ../../ocamlc" \
+ -linkall $(CAMLOBJS) $(LINKOPTS)
lib$(LIBNAME).$(A): $(COBJS)
$(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS)
$(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx)
- $(MKLIB) -o $(LIBNAME)nat -ocamlopt "..\\..\\boot\\ocamlrun ..\\..\\ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS)
+ $(MKLIB) -o $(LIBNAME)nat \
+ -ocamlopt "../../boot/ocamlrun ../../ocamlopt" -linkall \
+ $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS)
mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa
mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A)
$(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS)
st_stubs_n.$(O): st_stubs.c st_win32.h
- $(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c st_stubs.c
+ $(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun \
+ $(NATIVECCCOMPOPTS) -c st_stubs.c
mv st_stubs.$(O) st_stubs_n.$(O)
$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
(* *)
(***********************************************************************)
-(* $Id: condition.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type t
external create: unit -> t = "caml_condition_new"
external wait: t -> Mutex.t -> unit = "caml_condition_wait"
(* *)
(***********************************************************************)
-(* $Id: condition.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Condition variables to synchronize between threads.
Condition variables are used when one thread wants to wait until another
- thread has finished doing something: the former thread ``waits'' on the
- condition variable, the latter thread ``signals'' the condition when it
+ thread has finished doing something: the former thread 'waits' on the
+ condition variable, the latter thread 'signals' the condition when it
is done. Condition variables should always be protected by a mutex.
The typical use is (if [D] is a shared data structure, [m] its mutex,
and [c] is a condition variable):
(* *)
(***********************************************************************)
-(* $Id: event.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Events *)
type 'a basic_event =
{ poll: unit -> bool;
(* *)
(***********************************************************************)
-(* $Id: event.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** First-class synchronous communication.
This module implements synchronous inter-thread communications over
operation. *)
val sync : 'a event -> 'a
-(** ``Synchronize'' on an event: offer all the communication
+(** 'Synchronize' on an event: offer all the communication
possibilities specified in the event to the outside world,
and block until one of the communications succeed. The result
value of that communication is returned. *)
val select : 'a event list -> 'a
-(** ``Synchronize'' on an alternative of events.
+(** 'Synchronize' on an alternative of events.
[select evl] is shorthand for [sync(choose evl)]. *)
val poll : 'a event -> 'a option
(* *)
(***********************************************************************)
-(* $Id: mutex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type t
external create: unit -> t = "caml_mutex_new"
external lock: t -> unit = "caml_mutex_lock"
(* *)
(***********************************************************************)
-(* $Id: mutex.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Locks for mutual exclusion.
Mutexes (mutual-exclusion locks) are used to implement critical sections
/* */
/***********************************************************************/
-/* $Id$ */
-
/* POSIX thread implementation of the "st" interface */
#include <errno.h>
/* */
/***********************************************************************/
-/* $Id: st_stubs.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include "alloc.h"
#include "backtrace.h"
#include "callback.h"
th->exit_buf = NULL;
#else
/* Allocate the stacks */
- th->stack_low = (value *) stat_alloc(Thread_stack_size);
+ th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
th->sp = th->stack_high;
st_tls_newkey(&last_channel_locked_key);
/* Set up a thread info block for the current thread */
curr_thread =
- (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
+ (caml_thread_t) caml_stat_alloc(sizeof(struct caml_thread_struct));
curr_thread->descr = caml_thread_new_descriptor(Val_unit);
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
CAMLprim value caml_condition_broadcast(value wrapper) /* ML */
{
st_check_error(st_condvar_broadcast(Condition_val(wrapper)),
- "Condition.signal");
+ "Condition.broadcast");
return Val_unit;
}
/* */
/***********************************************************************/
-/* $Id$ */
-
/* Win32 implementation of the "st" interface */
#define _WIN32_WINNT 0x0400
#include <windows.h>
-#include <WinError.h>
+#include <winerror.h>
#include <stdio.h>
#include <signal.h>
#else
#include <stdio.h>
#define TRACE(x) printf("%d: %s\n", GetCurrentThreadId(), x); fflush(stdout)
-#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); fflush(stdout)
+#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); \
+ fflush(stdout)
#endif
typedef DWORD st_retcode;
(* *)
(***********************************************************************)
-(* $Id$ *)
-
(* User-level threads *)
type t
let wait_pid p = Unix.waitpid [] p
-external sigmask : Unix.sigprocmask_command -> int list -> int list = "caml_thread_sigmask"
+external sigmask : Unix.sigprocmask_command -> int list -> int list
+ = "caml_thread_sigmask"
external wait_signal : int list -> int = "caml_wait_signal"
(* *)
(***********************************************************************)
-(* $Id: thread.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Lightweight threads for Posix [1003.1c] and Win32. *)
type t
(* *)
(***********************************************************************)
-(* $Id: threadUnix.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [ThreadUnix]: thread-compatible system calls *)
open Unix
(* *)
(***********************************************************************)
-(* $Id: threadUnix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Thread-compatible system calls.
@deprecated The functionality of this module has been merged back into
/* */
/***********************************************************************/
-/* $Id$ */
-
#ifndef CAML_THREADS_H
#define CAML_THREADS_H
../../byterun/sys.h
condition.cmi : mutex.cmi
event.cmi :
-marshal.cmi :
mutex.cmi :
-pervasives.cmi :
-thread.cmi : unix.cmi
-threadUnix.cmi : unix.cmi
-unix.cmi :
+thread.cmi : unix.cmo
+threadUnix.cmi : unix.cmo
condition.cmo : thread.cmi mutex.cmi condition.cmi
condition.cmx : thread.cmx mutex.cmx condition.cmi
event.cmo : mutex.cmi condition.cmi event.cmi
event.cmx : mutex.cmx condition.cmx event.cmi
-marshal.cmo : pervasives.cmi marshal.cmi
-marshal.cmx : pervasives.cmx marshal.cmi
+marshal.cmo : pervasives.cmo
+marshal.cmx : pervasives.cmx
mutex.cmo : thread.cmi mutex.cmi
mutex.cmx : thread.cmx mutex.cmi
-pervasives.cmo : unix.cmi pervasives.cmi
-pervasives.cmx : unix.cmx pervasives.cmi
-thread.cmo : unix.cmi thread.cmi
+pervasives.cmo : unix.cmo
+pervasives.cmx : unix.cmx
+thread.cmo : unix.cmo thread.cmi
thread.cmx : unix.cmx thread.cmi
-threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi
+threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi
threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
-unix.cmo : unix.cmi
-unix.cmx : unix.cmi
+unix.cmo :
+unix.cmx :
# #
#########################################################################
-# $Id: Makefile 12867 2012-08-21 04:39:34Z garrigue $
-
include ../../config/Makefile
CC=$(BYTECC)
CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g
CAMLC=../../ocamlcomp.sh -I ../unix
MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
+COMPFLAGS=-w +33..39 -warn-error A
C_OBJS=scheduler.o
mkdir -p $(LIBDIR)/vmthreads
cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a
cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a
- cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads
- cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)/vmthreads
+ cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \
+ threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads
+ cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \
+ $(LIBDIR)/vmthreads
installopt:
(* *)
(***********************************************************************)
-(* $Id: condition.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type t = { mutable waiting: Thread.t list }
let create () = { waiting = [] }
(* *)
(***********************************************************************)
-(* $Id: condition.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Condition variables to synchronize between threads.
Condition variables are used when one thread wants to wait until another
(* *)
(***********************************************************************)
-(* $Id: event.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Events *)
type 'a basic_event =
{ poll: unit -> bool;
(* *)
(***********************************************************************)
-(* $Id: event.mli 12386 2012-04-20 15:33:00Z doligez $ *)
-
(** First-class synchronous communication.
This module implements synchronous inter-thread communications over
(* *)
(***********************************************************************)
-(* $Id: marshal.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type extern_flags =
No_sharing
| Closures
+ | Compat_32
external to_string: 'a -> extern_flags list -> string
= "caml_output_value_to_string"
(* *)
(***********************************************************************)
-(* $Id: mutex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type t = { mutable locked: bool; mutable waiting: Thread.t list }
let create () = { locked = false; waiting = [] }
(* *)
(***********************************************************************)
-(* $Id: mutex.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Locks for mutual exclusion.
Mutexes (mutual-exclusion locks) are used to implement critical sections
(* *)
(***********************************************************************)
-(* $Id: pervasives.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Same as ../../stdlib/pervasives.ml, except that I/O functions have
been redefined to not block the whole process, but only the calling
thread. *)
exception Exit
+(* Composition operators *)
+
+external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
(* Comparisons *)
external (=) : 'a -> 'a -> bool = "%equal"
external asin : float -> float = "caml_asin_float" "asin" "float"
external atan : float -> float = "caml_atan_float" "atan" "float"
external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
-external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float"
+external hypot : float -> float -> float
+ = "caml_hypot_float" "caml_hypot" "float"
external cos : float -> float = "caml_cos_float" "cos" "float"
external cosh : float -> float = "caml_cosh_float" "cosh" "float"
external log : float -> float = "caml_log_float" "log" "float"
external ceil : float -> float = "caml_ceil_float" "ceil" "float"
external floor : float -> float = "caml_floor_float" "floor" "float"
external abs_float : float -> float = "%absfloat"
-external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float"
+external copysign : float -> float -> float
+ = "caml_copysign_float" "caml_copysign" "float"
external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
external frexp : float -> float * int = "caml_frexp_float"
external ldexp : float -> int -> float = "caml_ldexp_float"
/* */
/***********************************************************************/
-/* $Id: scheduler.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The thread scheduler */
#include <string.h>
End_roots();
th->ident = next_ident;
next_ident = Val_int(Int_val(next_ident) + 1);
- th->stack_low = (value *) stat_alloc(Thread_stack_size);
+ th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
th->sp = th->stack_high;
(* *)
(***********************************************************************)
-(* $Id: thread.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* User-level threads *)
type t
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
| Resumed_wait of int * Unix.process_status
+(* to avoid warning *)
+let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
+ Resumed_io; Resumed_select ([], [], []);
+ Resumed_wait (0, Unix.WEXITED 0)]
+
(* It is mucho important that the primitives that reschedule are called
through an ML function call, not directly. That's because when such a
primitive returns, the bytecode interpreter is only semi-obedient:
must take exactly one argument. *)
external thread_initialize : unit -> unit = "thread_initialize"
-external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption"
+external thread_initialize_preemption : unit -> unit
+ = "thread_initialize_preemption"
external thread_new : (unit -> unit) -> t = "thread_new"
external thread_yield : unit -> unit = "thread_yield"
external thread_request_reschedule : unit -> unit = "thread_request_reschedule"
(* *)
(***********************************************************************)
-(* $Id: thread.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Lightweight threads. *)
type t
(* *)
(***********************************************************************)
-(* $Id: threadUnix.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [ThreadUnix]: thread-compatible system calls *)
let execv = Unix.execv
(* *)
(***********************************************************************)
-(* $Id: threadUnix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Thread-compatible system calls.
@deprecated The functionality of this module has been merged back into
(* *)
(***********************************************************************)
-(* $Id: unix.ml 11304 2011-12-13 16:18:13Z frisch $ *)
-
(* An alternate implementation of the Unix module from ../unix
which is safe in conjunction with bytecode threads. *)
| Resumed_select of file_descr list * file_descr list * file_descr list
| Resumed_wait of int * process_status
+(* to avoid warning *)
+let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
+ Resumed_io; Resumed_select ([], [], []);
+ Resumed_wait (0, WEXITED 0)]
+
external thread_initialize : unit -> unit = "thread_initialize"
external thread_wait_read : file_descr -> unit = "thread_wait_read"
external thread_wait_write : file_descr -> unit = "thread_wait_write"
| O_SYNC
| O_RSYNC
| O_SHARE_DELETE
+ | O_CLOEXEC
type file_perm = int
addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \
../../byterun/compatibility.h ../../byterun/config.h \
../../byterun/../config/m.h ../../byterun/../config/s.h \
- ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \
+ ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+ ../../byterun/mlvalues.h ../../byterun/major_gc.h \
+ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
unixsupport.h socketaddr.h ../../byterun/misc.h
alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../byterun/../config/m.h \
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the Unix interface library
LIBNAME=unix
/* */
/***********************************************************************/
-/* $Id: accept.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: access.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: addrofstr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
+#include <memory.h>
#include <fail.h>
#include "unixsupport.h"
CAMLprim value unix_inet_addr_of_string(value s)
{
#if defined(HAS_IPV6)
+#ifdef _WIN32
+ CAMLparam1(s);
+ CAMLlocal1(vres);
+ struct addrinfo hints;
+ struct addrinfo * res;
+ int retcode;
+ memset(&hints, 0, sizeof(hints));
+ hints.ai_family = AF_UNSPEC;
+ hints.ai_flags = AI_NUMERICHOST;
+ retcode = getaddrinfo(String_val(s), NULL, &hints, &res);
+ if (retcode != 0) failwith("inet_addr_of_string");
+ switch (res->ai_addr->sa_family) {
+ case AF_INET:
+ {
+ vres =
+ alloc_inet_addr(&((struct sockaddr_in *) res->ai_addr)->sin_addr);
+ break;
+ }
+ case AF_INET6:
+ {
+ vres =
+ alloc_inet6_addr(&((struct sockaddr_in6 *) res->ai_addr)->sin6_addr);
+ break;
+ }
+ default:
+ {
+ freeaddrinfo(res);
+ failwith("inet_addr_of_string");
+ }
+ }
+ freeaddrinfo(res);
+ CAMLreturn (vres);
+#else
struct in_addr address;
struct in6_addr address6;
if (inet_pton(AF_INET, String_val(s), &address) > 0)
return alloc_inet6_addr(&address6);
else
failwith("inet_addr_of_string");
+#endif
#elif defined(HAS_INET_ATON)
struct in_addr address;
if (inet_aton(String_val(s), &address) == 0)
/* */
/***********************************************************************/
-/* $Id: alarm.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: bind.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: chdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: chmod.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <sys/stat.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: chown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: chroot.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: close.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: closedir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
#include <errno.h>
/* */
/***********************************************************************/
-/* $Id: connect.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include <signals.h>
/* */
/***********************************************************************/
-/* $Id: cst2constr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <fail.h>
#include "cst2constr.h"
/* */
/***********************************************************************/
-/* $Id: cst2constr.h 11156 2011-07-27 14:17:02Z doligez $ */
-
extern value cst_to_constr(int n, int * tbl, int size, int deflt);
/* */
/***********************************************************************/
-/* $Id: cstringv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include "unixsupport.h"
mlsize_t size, i;
size = Wosize_val(arg);
- res = (char **) stat_alloc((size + 1) * sizeof(char *));
+ res = (char **) caml_stat_alloc((size + 1) * sizeof(char *));
for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i));
res[size] = NULL;
return res;
/* */
/***********************************************************************/
-/* $Id: dup.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: dup2.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: envir.c 11176 2011-09-05 09:25:26Z xclerc $ */
-
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: errmsg.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <string.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: execv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: execve.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: execvp.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: exit.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: fchmod.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <sys/stat.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: fchown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: fcntl.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: fork.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <debugger.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: ftruncate.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: getaddrinfo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <alloc.h>
if (len == 0) {
node = NULL;
} else {
- node = stat_alloc(len + 1);
+ node = caml_stat_alloc(len + 1);
strcpy(node, String_val(vnode));
}
/* Extract "service" parameter */
if (len == 0) {
serv = NULL;
} else {
- serv = stat_alloc(len + 1);
+ serv = caml_stat_alloc(len + 1);
strcpy(serv, String_val(vserv));
}
/* Parse options, set hints */
/* */
/***********************************************************************/
-/* $Id: getcwd.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: getegid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: geteuid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getgid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getgr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <fail.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: gethost.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <alloc.h>
char * hostname;
#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
- hostname = stat_alloc(string_length(name) + 1);
+ hostname = caml_stat_alloc(string_length(name) + 1);
strcpy(hostname, String_val(name));
#else
hostname = String_val(name);
/* */
/***********************************************************************/
-/* $Id: gethostname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
-#if defined (_WIN32)
-#include <winsock.h>
-#else
+#ifndef _WIN32
#include <sys/param.h>
#endif
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getlogin.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getnameinfo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getpeername.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getpid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getppid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getproto.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
#ifndef _WIN32
#include <netdb.h>
-#else
-#include <winsock.h>
#endif
static value alloc_proto_entry(struct protoent *entry)
/* */
/***********************************************************************/
-/* $Id: getpw.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
Begin_roots5 (name, passwd, gecos, dir, shell);
name = copy_string(entry->pw_name);
passwd = copy_string(entry->pw_passwd);
-#ifndef __BEOS__
+#if !defined(__BEOS__) && !defined(__ANDROID__)
gecos = copy_string(entry->pw_gecos);
#else
gecos = copy_string("");
/* */
/***********************************************************************/
-/* $Id: getserv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
-#else
-#include <winsock.h>
#endif
static value alloc_service_entry(struct servent *entry)
/* */
/***********************************************************************/
-/* $Id: getsockname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: gettimeofday.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: getuid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: gmtime.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: initgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: isatty.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: itimer.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: kill.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <fail.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: link.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: listen.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: lockf.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <fcntl.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: lseek.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <sys/types.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: mkdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <sys/stat.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: mkfifo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <sys/stat.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: nice.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
#include <errno.h>
/* */
/***********************************************************************/
-/* $Id: open.c 11304 2011-12-13 16:18:13Z frisch $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
#include <string.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
#include <fcntl.h>
#ifndef O_NONBLOCK
#ifndef O_RSYNC
#define O_RSYNC 0
#endif
+#ifndef O_CLOEXEC
+#define NEED_CLOEXEC_EMULATION
+#define O_CLOEXEC 0
+#endif
-static int open_flag_table[] = {
+static int open_flag_table[14] = {
O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
- O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0
+ O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC,
+ 0, /* O_SHARE_DELETE, Windows-only */
+ O_CLOEXEC
};
+#ifdef NEED_CLOEXEC_EMULATION
+static int open_cloexec_table[14] = {
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0,
+ 0,
+ 1
+};
+#endif
+
CAMLprim value unix_open(value path, value flags, value perm)
{
CAMLparam3(path, flags, perm);
- int ret, cv_flags;
+ int fd, cv_flags;
char * p;
cv_flags = convert_flag_list(flags, open_flag_table);
- p = stat_alloc(string_length(path) + 1);
+ p = caml_stat_alloc(string_length(path) + 1);
strcpy(p, String_val(path));
/* open on a named FIFO can block (PR#1533) */
enter_blocking_section();
- ret = open(p, cv_flags, Int_val(perm));
+ fd = open(p, cv_flags, Int_val(perm));
leave_blocking_section();
stat_free(p);
- if (ret == -1) uerror("open", path);
- CAMLreturn (Val_int(ret));
+ if (fd == -1) uerror("open", path);
+#if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC)
+ if (convert_flag_list(flags, open_cloexec_table) != 0) {
+ int flags = fcntl(fd, F_GETFD, 0);
+ if (flags == -1 ||
+ fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
+ uerror("open", path);
+ }
+#endif
+ CAMLreturn (Val_int(fd));
}
/* */
/***********************************************************************/
-/* $Id: opendir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: pipe.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: putenv.c 12210 2012-03-08 19:52:03Z doligez $ */
-
#include <stdlib.h>
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: read.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <memory.h>
/* */
/***********************************************************************/
-/* $Id: readdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <fail.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: readlink.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: rename.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: rewinddir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: rmdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: select.c 12947 2012-09-24 11:25:32Z xleroy $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: sendrecv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: setgid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: setgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
int n;
size = Wosize_val(groups);
- gidset = (gid_t *) stat_alloc(size * sizeof(gid_t));
+ gidset = (gid_t *) caml_stat_alloc(size * sizeof(gid_t));
for (i = 0; i < size; i++) gidset[i] = Int_val(Field(groups, i));
n = setgroups(size, gidset);
/* */
/***********************************************************************/
-/* $Id: setsid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: setuid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: shutdown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: signals.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <signal.h>
/* */
/***********************************************************************/
-/* $Id: sleep.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: socket.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: socketaddr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: socketaddr.h 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include <misc.h>
+#include "misc.h"
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/un.h>
/* */
/***********************************************************************/
-/* $Id: socketpair.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: sockopt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: stat.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <mlvalues.h>
#include <memory.h>
/* */
/***********************************************************************/
-/* $Id: strofaddr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
{
char * res;
#ifdef HAS_IPV6
+#ifdef _WIN32
+ char buffer[64];
+ union sock_addr_union sa;
+ int len;
+ int retcode;
+ if (string_length(a) == 16) {
+ memset(&sa.s_inet6, 0, sizeof(struct sockaddr_in6));
+ sa.s_inet6.sin6_family = AF_INET6;
+ sa.s_inet6.sin6_addr = GET_INET6_ADDR(a);
+ len = sizeof(struct sockaddr_in6);
+ } else {
+ memset(&sa.s_inet, 0, sizeof(struct sockaddr_in));
+ sa.s_inet.sin_family = AF_INET;
+ sa.s_inet.sin_addr = GET_INET_ADDR(a);
+ len = sizeof(struct sockaddr_in);
+ }
+ retcode = getnameinfo
+ (&sa.s_gen, len, buffer, sizeof(buffer), NULL, 0, NI_NUMERICHOST);
+ if (retcode != 0)
+ res = NULL;
+ else
+ res = buffer;
+#else
char buffer[64];
if (string_length(a) == 16)
res = (char *)
res = (char *)
inet_ntop(AF_INET, (const void *) &GET_INET_ADDR(a),
buffer, sizeof(buffer));
+#endif
#else
res = inet_ntoa(GET_INET_ADDR(a));
#endif
/* */
/***********************************************************************/
-/* $Id: symlink.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: termios.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
return Val_unit;
}
+#if defined(__ANDROID__)
+CAMLprim value unix_tcdrain(value fd)
+{ invalid_argument("tcdrain not implemented"); }
+#else
CAMLprim value unix_tcdrain(value fd)
{
if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing);
return Val_unit;
}
+#endif
static int queue_flag_table[] = {
TCIFLUSH, TCOFLUSH, TCIOFLUSH
/* */
/***********************************************************************/
-/* $Id: time.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <time.h>
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: times.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
/* */
/***********************************************************************/
-/* $Id: truncate.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <mlvalues.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: umask.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <sys/types.h>
#include <sys/stat.h>
#include <mlvalues.h>
(* *)
(***********************************************************************)
-(* $Id: unix.ml 12038 2012-01-18 09:28:05Z protzenk $ *)
-
type error =
E2BIG
| EACCES
external error_message : error -> string = "unix_error_message"
+let () =
+ Printexc.register_printer
+ (function
+ | Unix_error (e, s, s') ->
+ let msg = match e with
+ | E2BIG -> "E2BIG"
+ | EACCES -> "EACCES"
+ | EAGAIN -> "EAGAIN"
+ | EBADF -> "EBADF"
+ | EBUSY -> "EBUSY"
+ | ECHILD -> "ECHILD"
+ | EDEADLK -> "EDEADLK"
+ | EDOM -> "EDOM"
+ | EEXIST -> "EEXIST"
+ | EFAULT -> "EFAULT"
+ | EFBIG -> "EFBIG"
+ | EINTR -> "EINTR"
+ | EINVAL -> "EINVAL"
+ | EIO -> "EIO"
+ | EISDIR -> "EISDIR"
+ | EMFILE -> "EMFILE"
+ | EMLINK -> "EMLINK"
+ | ENAMETOOLONG -> "ENAMETOOLONG"
+ | ENFILE -> "ENFILE"
+ | ENODEV -> "ENODEV"
+ | ENOENT -> "ENOENT"
+ | ENOEXEC -> "ENOEXEC"
+ | ENOLCK -> "ENOLCK"
+ | ENOMEM -> "ENOMEM"
+ | ENOSPC -> "ENOSPC"
+ | ENOSYS -> "ENOSYS"
+ | ENOTDIR -> "ENOTDIR"
+ | ENOTEMPTY -> "ENOTEMPTY"
+ | ENOTTY -> "ENOTTY"
+ | ENXIO -> "ENXIO"
+ | EPERM -> "EPERM"
+ | EPIPE -> "EPIPE"
+ | ERANGE -> "ERANGE"
+ | EROFS -> "EROFS"
+ | ESPIPE -> "ESPIPE"
+ | ESRCH -> "ESRCH"
+ | EXDEV -> "EXDEV"
+ | EWOULDBLOCK -> "EWOULDBLOCK"
+ | EINPROGRESS -> "EINPROGRESS"
+ | EALREADY -> "EALREADY"
+ | ENOTSOCK -> "ENOTSOCK"
+ | EDESTADDRREQ -> "EDESTADDRREQ"
+ | EMSGSIZE -> "EMSGSIZE"
+ | EPROTOTYPE -> "EPROTOTYPE"
+ | ENOPROTOOPT -> "ENOPROTOOPT"
+ | EPROTONOSUPPORT -> "EPROTONOSUPPORT"
+ | ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT"
+ | EOPNOTSUPP -> "EOPNOTSUPP"
+ | EPFNOSUPPORT -> "EPFNOSUPPORT"
+ | EAFNOSUPPORT -> "EAFNOSUPPORT"
+ | EADDRINUSE -> "EADDRINUSE"
+ | EADDRNOTAVAIL -> "EADDRNOTAVAIL"
+ | ENETDOWN -> "ENETDOWN"
+ | ENETUNREACH -> "ENETUNREACH"
+ | ENETRESET -> "ENETRESET"
+ | ECONNABORTED -> "ECONNABORTED"
+ | ECONNRESET -> "ECONNRESET"
+ | ENOBUFS -> "ENOBUFS"
+ | EISCONN -> "EISCONN"
+ | ENOTCONN -> "ENOTCONN"
+ | ESHUTDOWN -> "ESHUTDOWN"
+ | ETOOMANYREFS -> "ETOOMANYREFS"
+ | ETIMEDOUT -> "ETIMEDOUT"
+ | ECONNREFUSED -> "ECONNREFUSED"
+ | EHOSTDOWN -> "EHOSTDOWN"
+ | EHOSTUNREACH -> "EHOSTUNREACH"
+ | ELOOP -> "ELOOP"
+ | EOVERFLOW -> "EOVERFLOW"
+ | EUNKNOWNERR x -> Printf.sprintf "EUNKNOWNERR %d" x in
+ Some (Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" msg s s')
+ | _ -> None)
+
let handle_unix_error f arg =
try
f arg
external execvpe : string -> string array -> string array -> 'a = "unix_execvpe"
external fork : unit -> int = "unix_fork"
external wait : unit -> int * process_status = "unix_wait"
-external waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid"
+external waitpid : wait_flag list -> int -> int * process_status
+ = "unix_waitpid"
external getpid : unit -> int = "unix_getpid"
external getppid : unit -> int = "unix_getppid"
external nice : int -> int = "unix_nice"
| O_SYNC
| O_RSYNC
| O_SHARE_DELETE
+ | O_CLOEXEC
type file_perm = int
external close : file_descr -> unit = "unix_close"
external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
-external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int
+ = "unix_single_write"
let read fd buf ofs len =
if ofs < 0 || len < 0 || ofs > String.length buf - len
module LargeFile =
struct
- external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
+ external lseek : file_descr -> int64 -> seek_command -> int64
+ = "unix_lseek_64"
external truncate : string -> int64 -> unit = "unix_truncate_64"
external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
type stats =
(* High-level process management (system, popen) *)
+let rec waitpid_non_intr pid =
+ try waitpid [] pid
+ with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
let system cmd =
match fork() with
0 -> begin try
with _ ->
exit 127
end
- | id -> snd(waitpid [] id)
+ | id -> snd(waitpid_non_intr id)
let rec safe_dup fd =
let new_fd = dup fd in
with Not_found ->
raise(Unix_error(EBADF, fun_name, ""))
-let rec waitpid_non_intr pid =
- try waitpid [] pid
- with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
-
let close_process_in inchan =
let pid = find_proc_id "close_process_in" (Process_in inchan) in
close_in inchan;
(* *)
(***********************************************************************)
-(* $Id: unix.mli 12140 2012-02-07 16:41:02Z doligez $ *)
-
(** Interface to the Unix system *)
as the current process.
Negative pid arguments represent process groups.
The list of options indicates whether [waitpid] should return
- immediately without waiting, or also report stopped children. *)
+ immediately without waiting, and whether it should report stopped
+ children. *)
val system : string -> process_status
(** Execute the given command, wait until it terminates, and return
O_SYNC/O_DSYNC) *)
| O_SHARE_DELETE (** Windows only: allow the file to be deleted
while still open *)
+ | O_CLOEXEC (** Set the close-on-exec flag on the
+ descriptor returned by {!openfile} *)
+
(** The flags to {!Unix.openfile}. *)
read for group, none for others *)
val openfile : string -> open_flag list -> file_perm -> file_descr
-(** Open the named file with the given flags. Third argument is
- the permissions to give to the file if it is created. Return
- a file descriptor on the named file. *)
+(** Open the named file with the given flags. Third argument is the
+ permissions to give to the file if it is created (see
+ {!umask}). Return a file descriptor on the named file. *)
val close : file_descr -> unit
(** Close a file descriptor. *)
val lseek : file_descr -> int -> seek_command -> int
-(** Set the current position for a file descriptor *)
+(** Set the current position for a file descriptor, and return the resulting
+ offset (from the beginning of the file). *)
val truncate : string -> int -> unit
(** Truncates the named file to the given size. *)
val mkdir : string -> file_perm -> unit
-(** Create a directory with the given permissions. *)
+(** Create a directory with the given permissions (see {!umask}). *)
val rmdir : string -> unit
(** Remove an empty directory. *)
opened for writing, that's the entrance to the pipe. *)
val mkfifo : string -> file_perm -> unit
-(** Create a named pipe with the given permissions. *)
+(** Create a named pipe with the given permissions (see {!umask}). *)
(** {6 High-level process and redirection management} *)
(* *)
(***********************************************************************)
-(* $Id: unixLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [UnixLabels]: labelled Unix module *)
include Unix
(* *)
(***********************************************************************)
-(* $Id: unixLabels.mli 11307 2011-12-13 17:59:10Z frisch $ *)
-
(** Interface to the Unix system.
To use as replacement to default {!Unix} module,
add [module Unix = UnixLabels] in your implementation.
and termination status. *)
val waitpid : mode:wait_flag list -> int -> int * process_status
-(** Same as {!UnixLabels.wait}, but waits for the child process whose pid is given.
+(** Same as {!UnixLabels.wait}, but waits for the child process whose pid
+ is given.
A pid of [-1] means wait for any child.
A pid of [0] means wait for any child in the same process group
as the current process.
| O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *)
| O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
| O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *)
+ | O_CLOEXEC (** Set the close-on-exec flag on the
+ descriptor returned by {!openfile} *)
(** The flags to {!UnixLabels.openfile}. *)
val lseek : file_descr -> int -> mode:seek_command -> int
-(** Set the current position for a file descriptor *)
+(** Set the current position for a file descriptor, and return the resulting
+ offset (from the beginning of the file). *)
val truncate : string -> len:int -> unit
(** Truncates the named file to the given size. *)
/* */
/***********************************************************************/
-/* $Id: unixsupport.c 11915 2011-12-21 13:08:48Z protzenk $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <callback.h>
return err;
}
+extern int code_of_unix_error (value error)
+{
+ if (Is_block(error)) {
+ return Int_val(Field(error, 0));
+ } else {
+ return error_table[Int_val(error)];
+ }
+}
+
void unix_error(int errcode, char *cmdname, value cmdarg)
{
value res;
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Unix.Unix_error");
if (unix_error_exn == NULL)
- invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
+ invalid_argument("Exception Unix.Unix_error not initialized,"
+ " please link unix.cma");
}
res = alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
/* */
/***********************************************************************/
-/* $Id: unixsupport.h 12488 2012-05-28 11:31:30Z frisch $ */
-
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
#define Nothing ((value) 0)
extern value unix_error_of_code (int errcode);
+extern int code_of_unix_error (value error);
extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
extern void uerror (char * cmdname, value arg) Noreturn;
/* */
/***********************************************************************/
-/* $Id: unlink.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: utimes.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: wait.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: write.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <string.h>
#include <mlvalues.h>
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
LIBNAME=graphics
COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O)
CAMLOBJS=graphics.cmo
/* */
/***********************************************************************/
-/* $Id: dib.c 11156 2011-07-27 14:17:02Z doligez $ */
-
//-----------------------------------------------------------------------------
// DIB.C
//
/* */
/***********************************************************************/
-/* $Id: draw.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <math.h>
#include "mlvalues.h"
#include "alloc.h"
/* */
/***********************************************************************/
-/* $Id: events.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "mlvalues.h"
#include "alloc.h"
#include "libgraph.h"
/* */
/***********************************************************************/
-/* $Id: libgraph.h 12149 2012-02-10 16:15:24Z doligez $ */
-
#include <stdio.h>
#include <windows.h>
#include <windowsx.h>
/* */
/***********************************************************************/
-/* $Id: open.c 12149 2012-02-10 16:15:24Z doligez $ */
-
#include <fcntl.h>
#include <signal.h>
#include "mlvalues.h"
// End application
case WM_DESTROY:
ResetForClose(hwnd);
+ gr_check_open();
break;
}
caml_gr_handle_event(msg, wParam, lParam);
execve.c
execvp.c
exit.c
+getaddrinfo.c
getcwd.c
gethost.c
gethostname.c
+getnameinfo.c
getproto.c
getserv.c
gmtime.c
# #
#########################################################################
-# $Id: Makefile.nt 11912 2011-12-21 09:43:13Z protzenk $
-
# Files in this directory
WIN_FILES = accept.c bind.c channels.c close.c \
close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
# Files from the ../unix directory
UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
cstringv.c envir.c execv.c execve.c execvp.c \
- exit.c getcwd.c gethost.c gethostname.c getproto.c \
+ exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
+ getnameinfo.c getproto.c \
getserv.c gmtime.c putenv.c rmdir.c \
socketaddr.c strofaddr.c time.c unlink.c utimes.c
/* */
/***********************************************************************/
-/* $Id: accept.c 12480 2012-05-24 16:40:59Z xleroy $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
+#include <mswsock.h> // for SO_OPENTYPE and SO_SYNCHRONOUS_NONALERT
#include "socketaddr.h"
CAMLprim value unix_accept(sock)
/* */
/***********************************************************************/
-/* $Id: bind.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
#include "socketaddr.h"
/* */
/***********************************************************************/
-/* $Id: channels.c 11927 2011-12-21 16:31:01Z xleroy $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <io.h>
/* */
/***********************************************************************/
-/* $Id: close.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
#include <io.h>
/* */
/***********************************************************************/
-/* $Id: close_on.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include <mlvalues.h>
-#include <windows.h>
#include "unixsupport.h"
+#include <windows.h>
int win_set_inherit(value fd, BOOL inherit)
{
/* */
/***********************************************************************/
-/* $Id: connect.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: createprocess.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include <windows.h>
#include <mlvalues.h>
-#include <osdeps.h>
#include "unixsupport.h"
+#include <windows.h>
+#include <osdeps.h>
static int win_has_console(void);
/* */
/***********************************************************************/
-/* $Id: dup.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: dup2.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: errmsg.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <errno.h>
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: getpeername.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
#include "socketaddr.h"
/* */
/***********************************************************************/
-/* $Id: getpid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getsockname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
#include "socketaddr.h"
/* */
/***********************************************************************/
-/* $Id: gettimeofday.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <time.h>
#include "unixsupport.h"
+#ifdef HAS_MKTIME
+static double initial_time = 0; /* 0 means uninitialized */
+#else
static time_t initial_time = 0; /* 0 means uninitialized */
+#endif
static DWORD initial_tickcount;
CAMLprim value unix_gettimeofday(value unit)
{
DWORD tickcount = GetTickCount();
+ SYSTEMTIME st;
+ struct tm tm;
if (initial_time == 0 || tickcount < initial_tickcount) {
initial_tickcount = tickcount;
+#ifdef HAS_MKTIME
+ GetLocalTime(&st);
+ tm.tm_sec = st.wSecond;
+ tm.tm_min = st.wMinute;
+ tm.tm_hour = st.wHour;
+ tm.tm_mday = st.wDay;
+ tm.tm_mon = st.wMonth - 1;
+ tm.tm_year = st.wYear - 1900;
+ tm.tm_wday = 0;
+ tm.tm_yday = 0;
+ tm.tm_isdst = -1;
+ initial_time = ((double) mktime(&tm) + (double) st.wMilliseconds * 1e-3);
+#else
initial_time = time(NULL);
+#endif
return copy_double((double) initial_time);
} else {
return copy_double((double) initial_time +
/* */
/***********************************************************************/
-/* $Id: link.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include <windows.h>
#include <mlvalues.h>
#include <fail.h>
#include "unixsupport.h"
+#include <windows.h>
typedef
BOOL (WINAPI *tCreateHardLink)(
/* */
/***********************************************************************/
-/* $Id: listen.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: lockf.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <fcntl.h>
#include <mlvalues.h>
version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
if(GetVersionEx(&version) == 0) {
- invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform.");
+ invalid_argument("lockf only supported on WIN32_NT platforms:"
+ " could not determine current platform.");
}
if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) {
invalid_argument("lockf only supported on WIN32_NT platforms");
/* */
/***********************************************************************/
-/* $Id: lseek.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: mkdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: nonblock.c 11223 2011-10-15 09:02:22Z xleroy $ */
-
#include <mlvalues.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: open.c 11305 2011-12-13 16:21:10Z frisch $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include "unixsupport.h"
#include <fcntl.h>
-static int open_access_flags[13] = {
+static int open_access_flags[14] = {
GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+};
+
+static int open_create_flags[14] = {
+ 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0
};
-static int open_create_flags[13] = {
- 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0
+static int open_share_flags[14] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0
};
-static int open_share_flags[13] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE
+static int open_cloexec_flags[14] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1
};
CAMLprim value unix_open(value path, value flags, value perm)
{
- int fileaccess, createflags, fileattrib, filecreate, sharemode;
+ int fileaccess, createflags, fileattrib, filecreate, sharemode, cloexec;
SECURITY_ATTRIBUTES attr;
HANDLE h;
fileaccess = convert_flag_list(flags, open_access_flags);
- sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE | convert_flag_list(flags, open_share_flags);
+ sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE
+ | convert_flag_list(flags, open_share_flags);
createflags = convert_flag_list(flags, open_create_flags);
if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
else
fileattrib = FILE_ATTRIBUTE_NORMAL;
+ cloexec = convert_flag_list(flags, open_cloexec_flags);
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = TRUE;
+ attr.bInheritHandle = cloexec ? FALSE : TRUE;
h = CreateFile(String_val(path), fileaccess,
sharemode, &attr,
/* */
/***********************************************************************/
-/* $Id: pipe.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: read.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include <mlvalues.h>
#include <memory.h>
/* */
/***********************************************************************/
-/* $Id: rename.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: select.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
#include <fail.h>
#include <signals.h>
-#include <winsock2.h>
-#include <windows.h>
+#include "winworker.h"
#include <stdio.h>
-#include "unixsupport.h"
#include "windbug.h"
-#include "winworker.h"
#include "winlist.h"
/* This constant define the maximum number of objects that
/* */
/***********************************************************************/
-/* $Id: sendrecv.c 11896 2011-12-20 12:37:52Z xleroy $ */
-
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
/* */
/***********************************************************************/
-/* $Id: shutdown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: sleep.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: socket.c 12480 2012-05-24 16:40:59Z xleroy $ */
-
#include <mlvalues.h>
#include "unixsupport.h"
+#include <mswsock.h> // for SO_OPENTYPE and SO_SYNCHRONOUS_NONALERT
int socket_domain_table[] = {
- PF_UNIX, PF_INET /*, PF_INET6 */
+ PF_UNIX, PF_INET,
+#if defined(HAS_IPV6)
+ PF_INET6
+#else
+ 0
+#endif
};
int socket_type_table[] = {
SOCKET s;
int oldvalue, oldvaluelen, newvalue, retcode;
+ #ifndef HAS_IPV6
/* IPv6 requires WinSock2, we must raise an error on PF_INET6 */
if (Int_val(domain) >= sizeof(socket_domain_table)/sizeof(int)) {
win32_maperr(WSAEPFNOSUPPORT);
uerror("socket", Nothing);
}
+ #endif
+
oldvaluelen = sizeof(oldvalue);
retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
(char *) &oldvalue, &oldvaluelen);
/* */
/***********************************************************************/
-/* $Id: socketaddr.h 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include <misc.h>
+#include "misc.h"
union sock_addr_union {
struct sockaddr s_gen;
struct sockaddr_in s_inet;
+#ifdef HAS_IPV6
+ struct sockaddr_in6 s_inet6;
+#endif
};
extern union sock_addr_union sock_addr;
socklen_param_type addr_len, int close_on_error);
CAMLprim value alloc_inet_addr (struct in_addr * inaddr);
#define GET_INET_ADDR(v) (*((struct in_addr *) (v)))
+
+#ifdef HAS_IPV6
+CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr);
+#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v)))
+#endif
/* */
/***********************************************************************/
-/* $Id: sockopt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <mlvalues.h>
#include <memory.h>
#include <fcntl.h>
#include <stdlib.h>
#include <mlvalues.h>
-#include "unixsupport.h"
#include "winworker.h"
#include "windbug.h"
/* */
/***********************************************************************/
-/* $Id: stat.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <mlvalues.h>
#include <memory.h>
/* */
/***********************************************************************/
-/* $Id: system.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include <alloc.h>
-#include <windows.h>
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* File contributed by Josh Berdine */
+/* */
+/* Copyright 2011 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../../LICENSE. */
+/* */
+/***********************************************************************/
+
#include <mlvalues.h>
+#include <alloc.h>
#include "unixsupport.h"
+#include <windows.h>
double to_sec(FILETIME ft) {
value unix_times(value unit) {
-
value res;
FILETIME creation, exit, stime, utime;
- if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) {
+ if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime,
+ &utime))) {
win32_maperr(GetLastError());
uerror("times", Nothing);
}
Store_double_field(res, 2, 0);
Store_double_field(res, 3, 0);
return res;
-
}
(* *)
(***********************************************************************)
-(* $Id: unix.ml 11912 2011-12-21 09:43:13Z protzenk $ *)
-
(* Initialization *)
external startup: unit -> unit = "win_startup"
| O_SYNC
| O_RSYNC
| O_SHARE_DELETE
+ | O_CLOEXEC
type file_perm = int
(* Interfacing with the standard input/output library *)
-external in_channel_of_descr: file_descr -> in_channel = "win_inchannel_of_filedescr"
-external out_channel_of_descr: file_descr -> out_channel = "win_outchannel_of_filedescr"
-external descr_of_in_channel : in_channel -> file_descr = "win_filedescr_of_channel"
-external descr_of_out_channel : out_channel -> file_descr = "win_filedescr_of_channel"
+external in_channel_of_descr: file_descr -> in_channel
+ = "win_inchannel_of_filedescr"
+external out_channel_of_descr: file_descr -> out_channel
+ = "win_outchannel_of_filedescr"
+external descr_of_in_channel : in_channel -> file_descr
+ = "win_filedescr_of_channel"
+external descr_of_out_channel : out_channel -> file_descr
+ = "win_filedescr_of_channel"
(* Seeking and truncating *)
module LargeFile =
struct
- external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
- let truncate name len = invalid_arg "Unix.LargeFile.truncate not implemented"
- let ftruncate name len = invalid_arg "Unix.LargeFile.ftruncate not implemented"
+ external lseek : file_descr -> int64 -> seek_command -> int64
+ = "unix_lseek_64"
+ let truncate name len =
+ invalid_arg "Unix.LargeFile.truncate not implemented"
+ let ftruncate name len =
+ invalid_arg "Unix.LargeFile.ftruncate not implemented"
type stats =
{ st_dev : int;
st_ino : int;
| AI_CANONNAME
| AI_PASSIVE
-let getaddrinfo node service opts =
+external getaddrinfo_system
+ : string -> string -> getaddrinfo_option list -> addr_info list
+ = "unix_getaddrinfo"
+
+let getaddrinfo_emulation node service opts =
(* Parse options *)
let opt_socktype = ref None
and opt_protocol = ref 0
addresses)
ports)
+let getaddrinfo node service opts =
+ try
+ List.rev(getaddrinfo_system node service opts)
+ with Invalid_argument _ ->
+ getaddrinfo_emulation node service opts
+
type name_info =
{ ni_hostname : string;
ni_service : string }
| NI_NUMERICSERV
| NI_DGRAM
-let getnameinfo addr opts =
+external getnameinfo_system
+ : sockaddr -> getnameinfo_option list -> name_info
+ = "unix_getnameinfo"
+
+let getnameinfo_emulation addr opts =
match addr with
| ADDR_UNIX f ->
{ ni_hostname = ""; ni_service = f } (* why not? *)
string_of_int p in
{ ni_hostname = hostname; ni_service = service }
+let getnameinfo addr opts =
+ try
+ getnameinfo_system addr opts
+ with Invalid_argument _ ->
+ getnameinfo_emulation addr opts
+
(* High-level process management (system, popen) *)
external win_create_process : string -> string -> string option ->
(* High-level network functions *)
let open_connection sockaddr =
- let domain =
- match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
let sock =
- socket domain SOCK_STREAM 0 in
- connect sock sockaddr;
- (in_channel_of_descr sock, out_channel_of_descr sock)
+ socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+ try
+ connect sock sockaddr;
+ set_close_on_exec sock;
+ (in_channel_of_descr sock, out_channel_of_descr sock)
+ with exn ->
+ close sock; raise exn
let shutdown_connection inchan =
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
/* */
/***********************************************************************/
-/* $Id: unixsupport.c 11223 2011-10-15 09:02:22Z xleroy $ */
-
#include <stddef.h>
#include <mlvalues.h>
#include <callback.h>
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Unix.Unix_error");
if (unix_error_exn == NULL)
- invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
+ invalid_argument("Exception Unix.Unix_error not initialized,"
+ " please link unix.cma");
}
res = alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
/* */
/***********************************************************************/
-/* $Id: unixsupport.h 12488 2012-05-28 11:31:30Z frisch $ */
-
#define WIN32_LEAN_AND_MEAN
#include <wtypes.h>
#include <winbase.h>
#include <direct.h>
#include <process.h>
#include <sys/types.h>
-#include <winsock.h>
+#include <winsock2.h>
+#ifdef HAS_IPV6
+#include <ws2tcpip.h>
+#include <wspiapi.h>
+#endif
struct filedescr {
union {
/* */
/***********************************************************************/
-/* $Id: windbug.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include "windbug.h"
int debug_test (void)
/* */
/***********************************************************************/
-/* $Id: windbug.h 12023 2012-01-14 09:40:49Z xleroy $ */
-
#ifdef DEBUG
#include <stdio.h>
#include <windows.h>
-/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty argument lists)
+/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty
+ argument lists)
*/
#define DEBUG_PRINT(fmt, ...) \
do \
{ \
if (debug_test()) \
{ \
- fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), GetCurrentThreadId()); \
+ fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), \
+ GetCurrentThreadId()); \
fprintf(stderr, fmt, ##__VA_ARGS__); \
fprintf(stderr, "\n"); \
fflush(stderr); \
/* */
/***********************************************************************/
-/* $Id: windir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <mlvalues.h>
#include <memory.h>
#include <errno.h>
/* */
/***********************************************************************/
-/* $Id: winlist.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Basic list function in C. */
#include "winlist.h"
/* */
/***********************************************************************/
-/* $Id: winlist.h 11156 2011-07-27 14:17:02Z doligez $ */
#ifndef _WINLIST_H
#define _WINLIST_H
/* */
/***********************************************************************/
-/* $Id: winwait.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include <windows.h>
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
+#include <signals.h>
#include "unixsupport.h"
+#include <windows.h>
#include <sys/types.h>
-#include <signals.h>
static value alloc_process_status(HANDLE pid, int status)
{
/* */
/***********************************************************************/
-/* $Id: winworker.c 11156 2011-07-27 14:17:02Z doligez $ */
-
+#include <mlvalues.h>
+#include <alloc.h>
+#include <memory.h>
+#include <signals.h>
#include "winworker.h"
#include "winlist.h"
#include "windbug.h"
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
typedef enum {
WORKER_CMD_NONE = 0,
struct _WORKER {
LIST lst; /* This structure is used as a list. */
- HANDLE hJobStarted; /* Event representing that the function has begun. */
- HANDLE hJobStop; /* Event that can be used to notify the function that it
- should stop processing. */
- HANDLE hJobDone; /* Event representing that the function has finished. */
+ HANDLE hJobStarted; /* Event representing that the function has begun.*/
+ HANDLE hJobStop; /* Event that can be used to notify the function
+ that it should stop processing. */
+ HANDLE hJobDone; /* Event representing that the function has
+ finished. */
void *lpJobUserData; /* User data for the job. */
WORKERFUNC hJobFunc; /* Function to be called during APC */
HANDLE hWorkerReady; /* Worker is ready. */
/* */
/***********************************************************************/
-/* $Id: winworker.h 11156 2011-07-27 14:17:02Z doligez $ */
#ifndef _WINWORKER_H
#define _WINWORKER_H
#define _WIN32_WINNT 0x0400
+#include "unixsupport.h"
#include <windows.h>
/* Pool of worker threads.
/* */
/***********************************************************************/
-/* $Id: write.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <errno.h>
#include <string.h>
#include <mlvalues.h>
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+open Location
+open Config
+open Parsetree
+open Asttypes
+
+(* First, some helpers to build AST fragments *)
+
+let map_flatten f l = List.flatten (List.map f l)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub # location loc; txt}
+
+module T = struct
+ (* Type expressions for the core language *)
+
+ let mk ?(loc = Location.none) x = {ptyp_desc = x; ptyp_loc = loc}
+ let any ?loc () = mk ?loc Ptyp_any
+ let var ?loc a = mk ?loc (Ptyp_var a)
+ let arrow ?loc a b c = mk ?loc (Ptyp_arrow (a, b, c))
+ let tuple ?loc a = mk ?loc (Ptyp_tuple a)
+ let constr ?loc a b = mk ?loc (Ptyp_constr (a, b))
+ let object_ ?loc a = mk ?loc (Ptyp_object a)
+ let class_ ?loc a b c = mk ?loc (Ptyp_class (a, b, c))
+ let alias ?loc a b = mk ?loc (Ptyp_alias (a, b))
+ let variant ?loc a b c = mk ?loc (Ptyp_variant (a, b, c))
+ let poly ?loc a b = mk ?loc (Ptyp_poly (a, b))
+ let package ?loc a b = mk ?loc (Ptyp_package (a, b))
+
+ let field_type ?(loc = Location.none) x = {pfield_desc = x; pfield_loc = loc}
+ let field ?loc s t =
+ let t =
+ (* The type-checker expects the field to be a Ptyp_poly. Maybe
+ it should wrap the type automatically... *)
+ match t.ptyp_desc with
+ | Ptyp_poly _ -> t
+ | _ -> poly ?loc [] t
+ in
+ field_type ?loc (Pfield (s, t))
+ let field_var ?loc () = field_type ?loc Pfield_var
+
+ let core_field_type sub {pfield_desc = desc; pfield_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pfield (s, d) -> field ~loc:(sub # location loc) s (sub # typ d)
+ | Pfield_var -> field_var ~loc ()
+
+ let row_field sub = function
+ | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl)
+ | Rinherit t -> Rinherit (sub # typ t)
+
+ let map sub {ptyp_desc = desc; ptyp_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Ptyp_any -> any ~loc ()
+ | Ptyp_var s -> var ~loc s
+ | Ptyp_arrow (lab, t1, t2) -> arrow ~loc lab (sub # typ t1) (sub # typ t2)
+ | Ptyp_tuple tyl -> tuple ~loc (List.map (sub # typ) tyl)
+ | Ptyp_constr (lid, tl) ->
+ constr ~loc (map_loc sub lid) (List.map (sub # typ) tl)
+ | Ptyp_object l -> object_ ~loc (List.map (core_field_type sub) l)
+ | Ptyp_class (lid, tl, ll) ->
+ class_ ~loc (map_loc sub lid) (List.map (sub # typ) tl) ll
+ | Ptyp_alias (t, s) -> alias ~loc (sub # typ t) s
+ | Ptyp_variant (rl, b, ll) ->
+ variant ~loc (List.map (row_field sub) rl) b ll
+ | Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t)
+ | Ptyp_package (lid, l) ->
+ package ~loc (map_loc sub lid)
+ (List.map (map_tuple (map_loc sub) (sub # typ)) l)
+
+ let map_type_declaration sub td =
+ {td with
+ ptype_cstrs =
+ List.map
+ (fun (ct1, ct2, loc) -> sub # typ ct1, sub # typ ct2, sub # location loc)
+ td.ptype_cstrs;
+ ptype_kind = sub # type_kind td.ptype_kind;
+ ptype_manifest = map_opt (sub # typ) td.ptype_manifest;
+ ptype_loc = sub # location td.ptype_loc;
+ }
+
+ let map_type_kind sub = function
+ | Ptype_abstract -> Ptype_abstract
+ | Ptype_variant l ->
+ let f (s, tl, t, loc) =
+ (map_loc sub s,
+ List.map (sub # typ) tl,
+ map_opt (sub # typ) t,
+ sub # location loc)
+ in
+ Ptype_variant (List.map f l)
+ | Ptype_record l ->
+ let f (s, flags, t, loc) =
+ (map_loc sub s, flags, sub # typ t, sub # location loc)
+ in
+ Ptype_record (List.map f l)
+end
+
+module CT = struct
+ (* Type expressions for the class language *)
+
+ let mk ?(loc = Location.none) x = {pcty_loc = loc; pcty_desc = x}
+
+ let constr ?loc a b = mk ?loc (Pcty_constr (a, b))
+ let signature ?loc a = mk ?loc (Pcty_signature a)
+ let fun_ ?loc a b c = mk ?loc (Pcty_fun (a, b, c))
+
+ let map sub {pcty_loc = loc; pcty_desc = desc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pcty_constr (lid, tys) ->
+ constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
+ | Pcty_signature x -> signature ~loc (sub # class_signature x)
+ | Pcty_fun (lab, t, ct) ->
+ fun_ ~loc lab
+ (sub # typ t)
+ (sub # class_type ct)
+
+ let mk_field ?(loc = Location.none) x = {pctf_desc = x; pctf_loc = loc}
+
+ let inher ?loc a = mk_field ?loc (Pctf_inher a)
+ let val_ ?loc a b c d = mk_field ?loc (Pctf_val (a, b, c, d))
+ let virt ?loc a b c = mk_field ?loc (Pctf_virt (a, b, c))
+ let meth ?loc a b c = mk_field ?loc (Pctf_meth (a, b, c))
+ let cstr ?loc a b = mk_field ?loc (Pctf_cstr (a, b))
+
+ let map_field sub {pctf_desc = desc; pctf_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pctf_inher ct -> inher ~loc (sub # class_type ct)
+ | Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t)
+ | Pctf_virt (s, p, t) -> virt ~loc s p (sub # typ t)
+ | Pctf_meth (s, p, t) -> meth ~loc s p (sub # typ t)
+ | Pctf_cstr (t1, t2) -> cstr ~loc (sub # typ t1) (sub # typ t2)
+
+ let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} =
+ {
+ pcsig_self = sub # typ pcsig_self;
+ pcsig_fields = List.map (sub # class_type_field) pcsig_fields;
+ pcsig_loc = sub # location pcsig_loc ;
+ }
+end
+
+module MT = struct
+ (* Type expressions for the module language *)
+
+ let mk ?(loc = Location.none) x = {pmty_desc = x; pmty_loc = loc}
+ let ident ?loc a = mk ?loc (Pmty_ident a)
+ let signature ?loc a = mk ?loc (Pmty_signature a)
+ let functor_ ?loc a b c = mk ?loc (Pmty_functor (a, b, c))
+ let with_ ?loc a b = mk ?loc (Pmty_with (a, b))
+ let typeof_ ?loc a = mk ?loc (Pmty_typeof a)
+
+ let map sub {pmty_desc = desc; pmty_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pmty_ident s -> ident ~loc (map_loc sub s)
+ | Pmty_signature sg -> signature ~loc (sub # signature sg)
+ | Pmty_functor (s, mt1, mt2) ->
+ functor_ ~loc (map_loc sub s) (sub # module_type mt1)
+ (sub # module_type mt2)
+ | Pmty_with (mt, l) ->
+ with_ ~loc (sub # module_type mt)
+ (List.map (map_tuple (map_loc sub) (sub # with_constraint)) l)
+ | Pmty_typeof me -> typeof_ ~loc (sub # module_expr me)
+
+ let map_with_constraint sub = function
+ | Pwith_type d -> Pwith_type (sub # type_declaration d)
+ | Pwith_module s -> Pwith_module (map_loc sub s)
+ | Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
+ | Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
+
+ let mk_item ?(loc = Location.none) x = {psig_desc = x; psig_loc = loc}
+
+ let value ?loc a b = mk_item ?loc (Psig_value (a, b))
+ let type_ ?loc a = mk_item ?loc (Psig_type a)
+ let exception_ ?loc a b = mk_item ?loc (Psig_exception (a, b))
+ let module_ ?loc a b = mk_item ?loc (Psig_module (a, b))
+ let rec_module ?loc a = mk_item ?loc (Psig_recmodule a)
+ let modtype ?loc a b = mk_item ?loc (Psig_modtype (a, b))
+ let open_ ?loc a b = mk_item ?loc (Psig_open (a, b))
+ let include_ ?loc a = mk_item ?loc (Psig_include a)
+ let class_ ?loc a = mk_item ?loc (Psig_class a)
+ let class_type ?loc a = mk_item ?loc (Psig_class_type a)
+
+ let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Psig_value (s, vd) ->
+ value ~loc (map_loc sub s) (sub # value_description vd)
+ | Psig_type l ->
+ type_ ~loc
+ (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l)
+ | Psig_exception (s, ed) ->
+ exception_ ~loc (map_loc sub s) (sub # exception_declaration ed)
+ | Psig_module (s, mt) ->
+ module_ ~loc (map_loc sub s) (sub # module_type mt)
+ | Psig_recmodule l ->
+ rec_module ~loc
+ (List.map (map_tuple (map_loc sub) (sub # module_type)) l)
+ | Psig_modtype (s, Pmodtype_manifest mt) ->
+ modtype ~loc (map_loc sub s) (Pmodtype_manifest (sub # module_type mt))
+ | Psig_modtype (s, Pmodtype_abstract) ->
+ modtype ~loc (map_loc sub s) Pmodtype_abstract
+ | Psig_open (ovf, s) -> open_ ~loc ovf (map_loc sub s)
+ | Psig_include mt -> include_ ~loc (sub # module_type mt)
+ | Psig_class l -> class_ ~loc (List.map (sub # class_description) l)
+ | Psig_class_type l ->
+ class_type ~loc (List.map (sub # class_type_declaration) l)
+
+end
+
+
+module M = struct
+ (* Value expressions for the module language *)
+
+ let mk ?(loc = Location.none) x = {pmod_desc = x; pmod_loc = loc}
+ let ident ?loc x = mk ?loc (Pmod_ident x)
+ let structure ?loc x = mk ?loc (Pmod_structure x)
+ let functor_ ?loc arg arg_ty body = mk ?loc (Pmod_functor (arg, arg_ty, body))
+ let apply ?loc m1 m2 = mk ?loc (Pmod_apply (m1, m2))
+ let constraint_ ?loc m mty = mk ?loc (Pmod_constraint (m, mty))
+ let unpack ?loc e = mk ?loc (Pmod_unpack e)
+
+ let map sub {pmod_loc = loc; pmod_desc = desc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pmod_ident x -> ident ~loc (map_loc sub x)
+ | Pmod_structure str -> structure ~loc (sub # structure str)
+ | Pmod_functor (arg, arg_ty, body) -> functor_ ~loc (map_loc sub arg) (sub # module_type arg_ty) (sub # module_expr body)
+ | Pmod_apply (m1, m2) -> apply ~loc (sub # module_expr m1) (sub # module_expr m2)
+ | Pmod_constraint (m, mty) -> constraint_ ~loc (sub # module_expr m) (sub # module_type mty)
+ | Pmod_unpack e -> unpack ~loc (sub # expr e)
+
+ let mk_item ?(loc = Location.none) x = {pstr_desc = x; pstr_loc = loc}
+ let eval ?loc a = mk_item ?loc (Pstr_eval a)
+ let value ?loc a b = mk_item ?loc (Pstr_value (a, b))
+ let primitive ?loc a b = mk_item ?loc (Pstr_primitive (a, b))
+ let type_ ?loc a = mk_item ?loc (Pstr_type a)
+ let exception_ ?loc a b = mk_item ?loc (Pstr_exception (a, b))
+ let exn_rebind ?loc a b = mk_item ?loc (Pstr_exn_rebind (a, b))
+ let module_ ?loc a b = mk_item ?loc (Pstr_module (a, b))
+ let rec_module ?loc a = mk_item ?loc (Pstr_recmodule a)
+ let modtype ?loc a b = mk_item ?loc (Pstr_modtype (a, b))
+ let open_ ?loc a b = mk_item ?loc (Pstr_open (a, b))
+ let class_ ?loc a = mk_item ?loc (Pstr_class a)
+ let class_type ?loc a = mk_item ?loc (Pstr_class_type a)
+ let include_ ?loc a = mk_item ?loc (Pstr_include a)
+
+ let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pstr_eval x -> eval ~loc (sub # expr x)
+ | Pstr_value (r, pel) -> value ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+ | Pstr_primitive (name, vd) -> primitive ~loc (map_loc sub name) (sub # value_description vd)
+ | Pstr_type l -> type_ ~loc (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l)
+ | Pstr_exception (name, ed) -> exception_ ~loc (map_loc sub name) (sub # exception_declaration ed)
+ | Pstr_exn_rebind (s, lid) -> exn_rebind ~loc (map_loc sub s) (map_loc sub lid)
+ | Pstr_module (s, m) -> module_ ~loc (map_loc sub s) (sub # module_expr m)
+ | Pstr_recmodule l -> rec_module ~loc (List.map (fun (s, mty, me) -> (map_loc sub s, sub # module_type mty, sub # module_expr me)) l)
+ | Pstr_modtype (s, mty) -> modtype ~loc (map_loc sub s) (sub # module_type mty)
+ | Pstr_open (ovf, lid) -> open_ ~loc ovf (map_loc sub lid)
+ | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
+ | Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
+ | Pstr_include e -> include_ ~loc (sub # module_expr e)
+end
+
+module E = struct
+ (* Value expressions for the core language *)
+
+ let mk ?(loc = Location.none) x = {pexp_desc = x; pexp_loc = loc}
+
+ let ident ?loc a = mk ?loc (Pexp_ident a)
+ let constant ?loc a = mk ?loc (Pexp_constant a)
+ let let_ ?loc a b c = mk ?loc (Pexp_let (a, b, c))
+ let function_ ?loc a b c = mk ?loc (Pexp_function (a, b, c))
+ let apply ?loc a b = mk ?loc (Pexp_apply (a, b))
+ let match_ ?loc a b = mk ?loc (Pexp_match (a, b))
+ let try_ ?loc a b = mk ?loc (Pexp_try (a, b))
+ let tuple ?loc a = mk ?loc (Pexp_tuple a)
+ let construct ?loc a b c = mk ?loc (Pexp_construct (a, b, c))
+ let variant ?loc a b = mk ?loc (Pexp_variant (a, b))
+ let record ?loc a b = mk ?loc (Pexp_record (a, b))
+ let field ?loc a b = mk ?loc (Pexp_field (a, b))
+ let setfield ?loc a b c = mk ?loc (Pexp_setfield (a, b, c))
+ let array ?loc a = mk ?loc (Pexp_array a)
+ let ifthenelse ?loc a b c = mk ?loc (Pexp_ifthenelse (a, b, c))
+ let sequence ?loc a b = mk ?loc (Pexp_sequence (a, b))
+ let while_ ?loc a b = mk ?loc (Pexp_while (a, b))
+ let for_ ?loc a b c d e = mk ?loc (Pexp_for (a, b, c, d, e))
+ let constraint_ ?loc a b c = mk ?loc (Pexp_constraint (a, b, c))
+ let when_ ?loc a b = mk ?loc (Pexp_when (a, b))
+ let send ?loc a b = mk ?loc (Pexp_send (a, b))
+ let new_ ?loc a = mk ?loc (Pexp_new a)
+ let setinstvar ?loc a b = mk ?loc (Pexp_setinstvar (a, b))
+ let override ?loc a = mk ?loc (Pexp_override a)
+ let letmodule ?loc (a, b, c)= mk ?loc (Pexp_letmodule (a, b, c))
+ let assert_ ?loc a = mk ?loc (Pexp_assert a)
+ let assertfalse ?loc () = mk ?loc Pexp_assertfalse
+ let lazy_ ?loc a = mk ?loc (Pexp_lazy a)
+ let poly ?loc a b = mk ?loc (Pexp_poly (a, b))
+ let object_ ?loc a = mk ?loc (Pexp_object a)
+ let newtype ?loc a b = mk ?loc (Pexp_newtype (a, b))
+ let pack ?loc a = mk ?loc (Pexp_pack a)
+ let open_ ?loc a b c = mk ?loc (Pexp_open (a, b, c))
+
+ let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc)
+ let apply_nolabs ?loc f el = apply ?loc f (List.map (fun e -> ("", e)) el)
+ let strconst ?loc x = constant ?loc (Const_string x)
+
+ let map sub {pexp_loc = loc; pexp_desc = desc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pexp_ident x -> ident ~loc (map_loc sub x)
+ | Pexp_constant x -> constant ~loc x
+ | Pexp_let (r, pel, e) -> let_ ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
+ | Pexp_function (lab, def, pel) -> function_ ~loc lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+ | Pexp_apply (e, l) -> apply ~loc (sub # expr e) (List.map (map_snd (sub # expr)) l)
+ | Pexp_match (e, l) -> match_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
+ | Pexp_try (e, l) -> try_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
+ | Pexp_tuple el -> tuple ~loc (List.map (sub # expr) el)
+ | Pexp_construct (lid, arg, b) -> construct ~loc (map_loc sub lid) (map_opt (sub # expr) arg) b
+ | Pexp_variant (lab, eo) -> variant ~loc lab (map_opt (sub # expr) eo)
+ | Pexp_record (l, eo) -> record ~loc (List.map (map_tuple (map_loc sub) (sub # expr)) l) (map_opt (sub # expr) eo)
+ | Pexp_field (e, lid) -> field ~loc (sub # expr e) (map_loc sub lid)
+ | Pexp_setfield (e1, lid, e2) -> setfield ~loc (sub # expr e1) (map_loc sub lid) (sub # expr e2)
+ | Pexp_array el -> array ~loc (List.map (sub # expr) el)
+ | Pexp_ifthenelse (e1, e2, e3) -> ifthenelse ~loc (sub # expr e1) (sub # expr e2) (map_opt (sub # expr) e3)
+ | Pexp_sequence (e1, e2) -> sequence ~loc (sub # expr e1) (sub # expr e2)
+ | Pexp_while (e1, e2) -> while_ ~loc (sub # expr e1) (sub # expr e2)
+ | Pexp_for (id, e1, e2, d, e3) -> for_ ~loc (map_loc sub id) (sub # expr e1) (sub # expr e2) d (sub # expr e3)
+ | Pexp_constraint (e, t1, t2) -> constraint_ ~loc (sub # expr e) (map_opt (sub # typ) t1) (map_opt (sub # typ) t2)
+ | Pexp_when (e1, e2) -> when_ ~loc (sub # expr e1) (sub # expr e2)
+ | Pexp_send (e, s) -> send ~loc (sub # expr e) s
+ | Pexp_new lid -> new_ ~loc (map_loc sub lid)
+ | Pexp_setinstvar (s, e) -> setinstvar ~loc (map_loc sub s) (sub # expr e)
+ | Pexp_override sel -> override ~loc (List.map (map_tuple (map_loc sub) (sub # expr)) sel)
+ | Pexp_letmodule (s, me, e) -> letmodule ~loc (map_loc sub s, sub # module_expr me, sub # expr e)
+ | Pexp_assert e -> assert_ ~loc (sub # expr e)
+ | Pexp_assertfalse -> assertfalse ~loc ()
+ | Pexp_lazy e -> lazy_ ~loc (sub # expr e)
+ | Pexp_poly (e, t) -> poly ~loc (sub # expr e) (map_opt (sub # typ) t)
+ | Pexp_object cls -> object_ ~loc (sub # class_structure cls)
+ | Pexp_newtype (s, e) -> newtype ~loc s (sub # expr e)
+ | Pexp_pack me -> pack ~loc (sub # module_expr me)
+ | Pexp_open (ovf, lid, e) -> open_ ~loc ovf (map_loc sub lid) (sub # expr e)
+end
+
+module P = struct
+ (* Patterns *)
+
+ let mk ?(loc = Location.none) x = {ppat_desc = x; ppat_loc = loc}
+ let any ?loc () = mk ?loc Ppat_any
+ let var ?loc a = mk ?loc (Ppat_var a)
+ let alias ?loc a b = mk ?loc (Ppat_alias (a, b))
+ let constant ?loc a = mk ?loc (Ppat_constant a)
+ let tuple ?loc a = mk ?loc (Ppat_tuple a)
+ let construct ?loc a b c = mk ?loc (Ppat_construct (a, b, c))
+ let variant ?loc a b = mk ?loc (Ppat_variant (a, b))
+ let record ?loc a b = mk ?loc (Ppat_record (a, b))
+ let array ?loc a = mk ?loc (Ppat_array a)
+ let or_ ?loc a b = mk ?loc (Ppat_or (a, b))
+ let constraint_ ?loc a b = mk ?loc (Ppat_constraint (a, b))
+ let type_ ?loc a = mk ?loc (Ppat_type a)
+ let lazy_ ?loc a = mk ?loc (Ppat_lazy a)
+ let unpack ?loc a = mk ?loc (Ppat_unpack a)
+
+ let map sub {ppat_desc = desc; ppat_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Ppat_any -> any ~loc ()
+ | Ppat_var s -> var ~loc (map_loc sub s)
+ | Ppat_alias (p, s) -> alias ~loc (sub # pat p) (map_loc sub s)
+ | Ppat_constant c -> constant ~loc c
+ | Ppat_tuple pl -> tuple ~loc (List.map (sub # pat) pl)
+ | Ppat_construct (l, p, b) -> construct ~loc (map_loc sub l) (map_opt (sub # pat) p) b
+ | Ppat_variant (l, p) -> variant ~loc l (map_opt (sub # pat) p)
+ | Ppat_record (lpl, cf) ->
+ record ~loc (List.map (map_tuple (map_loc sub) (sub # pat)) lpl) cf
+ | Ppat_array pl -> array ~loc (List.map (sub # pat) pl)
+ | Ppat_or (p1, p2) -> or_ ~loc (sub # pat p1) (sub # pat p2)
+ | Ppat_constraint (p, t) -> constraint_ ~loc (sub # pat p) (sub # typ t)
+ | Ppat_type s -> type_ ~loc (map_loc sub s)
+ | Ppat_lazy p -> lazy_ ~loc (sub # pat p)
+ | Ppat_unpack s -> unpack ~loc (map_loc sub s)
+end
+
+module CE = struct
+ (* Value expressions for the class language *)
+
+ let mk ?(loc = Location.none) x = {pcl_loc = loc; pcl_desc = x}
+
+ let constr ?loc a b = mk ?loc (Pcl_constr (a, b))
+ let structure ?loc a = mk ?loc (Pcl_structure a)
+ let fun_ ?loc a b c d = mk ?loc (Pcl_fun (a, b, c, d))
+ let apply ?loc a b = mk ?loc (Pcl_apply (a, b))
+ let let_ ?loc a b c = mk ?loc (Pcl_let (a, b, c))
+ let constraint_ ?loc a b = mk ?loc (Pcl_constraint (a, b))
+
+ let map sub {pcl_loc = loc; pcl_desc = desc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pcl_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
+ | Pcl_structure s ->
+ structure ~loc (sub # class_structure s)
+ | Pcl_fun (lab, e, p, ce) ->
+ fun_ ~loc lab
+ (map_opt (sub # expr) e)
+ (sub # pat p)
+ (sub # class_expr ce)
+ | Pcl_apply (ce, l) ->
+ apply ~loc (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
+ | Pcl_let (r, pel, ce) ->
+ let_ ~loc r
+ (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+ (sub # class_expr ce)
+ | Pcl_constraint (ce, ct) ->
+ constraint_ ~loc (sub # class_expr ce) (sub # class_type ct)
+
+
+ let mk_field ?(loc = Location.none) x = {pcf_desc = x; pcf_loc = loc}
+
+ let inher ?loc a b c = mk_field ?loc (Pcf_inher (a, b, c))
+ let valvirt ?loc a b c = mk_field ?loc (Pcf_valvirt (a, b, c))
+ let val_ ?loc a b c d = mk_field ?loc (Pcf_val (a, b, c, d))
+ let virt ?loc a b c = mk_field ?loc (Pcf_virt (a, b, c))
+ let meth ?loc a b c d = mk_field ?loc (Pcf_meth (a, b, c, d))
+ let constr ?loc a b = mk_field ?loc (Pcf_constr (a, b))
+ let init ?loc a = mk_field ?loc (Pcf_init a)
+
+ let map_field sub {pcf_desc = desc; pcf_loc = loc} =
+ let loc = sub # location loc in
+ match desc with
+ | Pcf_inher (o, ce, s) -> inher ~loc o (sub # class_expr ce) s
+ | Pcf_valvirt (s, m, t) -> valvirt ~loc (map_loc sub s) m (sub # typ t)
+ | Pcf_val (s, m, o, e) -> val_ ~loc (map_loc sub s) m o (sub # expr e)
+ | Pcf_virt (s, p, t) -> virt ~loc (map_loc sub s) p (sub # typ t)
+ | Pcf_meth (s, p, o, e) -> meth ~loc (map_loc sub s) p o (sub # expr e)
+ | Pcf_constr (t1, t2) -> constr ~loc (sub # typ t1) (sub # typ t2)
+ | Pcf_init e -> init ~loc (sub # expr e)
+
+ let map_structure sub {pcstr_pat; pcstr_fields} =
+ {
+ pcstr_pat = sub # pat pcstr_pat;
+ pcstr_fields = List.map (sub # class_field) pcstr_fields;
+ }
+
+ let class_infos sub f {pci_virt; pci_params = (pl, ploc); pci_name; pci_expr; pci_variance; pci_loc} =
+ {
+ pci_virt;
+ pci_params = List.map (map_loc sub) pl, sub # location ploc;
+ pci_name = map_loc sub pci_name;
+ pci_expr = f pci_expr;
+ pci_variance;
+ pci_loc = sub # location pci_loc;
+ }
+end
+
+(* Now, a generic AST mapper class, to be extended to cover all kinds
+ and cases of the OCaml grammar. The default behavior of the mapper
+ is the identity. *)
+
+class mapper =
+ object(this)
+ method implementation (input_name : string) ast = (input_name, this # structure ast)
+ method interface (input_name: string) ast = (input_name, this # signature ast)
+ method structure l = map_flatten (this # structure_item) l
+ method structure_item si = [ M.map_structure_item this si ]
+ method module_expr = M.map this
+
+ method signature l = map_flatten (this # signature_item) l
+ method signature_item si = [ MT.map_signature_item this si ]
+ method module_type = MT.map this
+ method with_constraint c = MT.map_with_constraint this c
+
+ method class_declaration = CE.class_infos this (this # class_expr)
+ method class_expr = CE.map this
+ method class_field = CE.map_field this
+ method class_structure = CE.map_structure this
+
+ method class_type = CT.map this
+ method class_type_field = CT.map_field this
+ method class_signature = CT.map_signature this
+
+ method class_type_declaration = CE.class_infos this (this # class_type)
+ method class_description = CE.class_infos this (this # class_type)
+
+ method type_declaration = T.map_type_declaration this
+ method type_kind = T.map_type_kind this
+ method typ = T.map this
+
+ method value_description {pval_type; pval_prim; pval_loc} =
+ {
+ pval_type = this # typ pval_type;
+ pval_prim;
+ pval_loc = this # location pval_loc;
+ }
+ method pat = P.map this
+ method expr = E.map this
+
+ method exception_declaration tl = List.map (this # typ) tl
+
+ method location l = l
+ end
+
+class type main_entry_points =
+ object
+ method implementation: string -> structure -> string * structure
+ method interface: string -> signature -> string * signature
+ end
+
+let apply ~source ~target mapper =
+ let ic = open_in_bin source in
+ let magic = String.create (String.length ast_impl_magic_number) in
+ really_input ic magic 0 (String.length magic);
+ if magic <> ast_impl_magic_number && magic <> ast_intf_magic_number then
+ failwith "Bad magic";
+ let input_name = input_value ic in
+ let ast = input_value ic in
+ close_in ic;
+
+ let (input_name, ast) =
+ if magic = ast_impl_magic_number
+ then Obj.magic (mapper # implementation input_name (Obj.magic ast))
+ else Obj.magic (mapper # interface input_name (Obj.magic ast))
+ in
+ let oc = open_out_bin target in
+ output_string oc magic;
+ output_value oc input_name;
+ output_value oc ast;
+ close_out oc
+
+let run_main mapper =
+ try
+ let a = Sys.argv in
+ let n = Array.length a in
+ if n > 2 then
+ apply ~source:a.(n - 2) ~target:a.(n - 1) (mapper (Array.to_list (Array.sub a 1 (n - 3))))
+ else begin
+ Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!" Sys.executable_name;
+ exit 1
+ end
+ with exn ->
+ prerr_endline (Printexc.to_string exn);
+ exit 2
+
+let main mapper = run_main (fun _ -> mapper)
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name (f :> string list -> mapper)
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(** Helpers to write Parsetree rewriters *)
+
+open Asttypes
+open Parsetree
+
+(** {2 A generic mapper class} *)
+
+class mapper:
+ object
+ method class_declaration: class_declaration -> class_declaration
+ method class_description: class_description -> class_description
+ method class_expr: class_expr -> class_expr
+ method class_field: class_field -> class_field
+ method class_signature: class_signature -> class_signature
+ method class_structure: class_structure -> class_structure
+ method class_type: class_type -> class_type
+ method class_type_declaration:
+ class_type_declaration -> class_type_declaration
+ method class_type_field: class_type_field -> class_type_field
+ method exception_declaration: exception_declaration -> exception_declaration
+ method expr: expression -> expression
+ method implementation: string -> structure -> string * structure
+ method interface: string -> signature -> string * signature
+ method location: Location.t -> Location.t
+ method module_expr: module_expr -> module_expr
+ method module_type: module_type -> module_type
+ method pat: pattern -> pattern
+ method signature: signature -> signature
+ method signature_item: signature_item -> signature_item list
+ method structure: structure -> structure
+ method structure_item: structure_item -> structure_item list
+ method typ: core_type -> core_type
+ method type_declaration: type_declaration -> type_declaration
+ method type_kind: type_kind -> type_kind
+ method value_description: value_description -> value_description
+ method with_constraint: with_constraint -> with_constraint
+ end
+
+class type main_entry_points =
+ object
+ method implementation: string -> structure -> string * structure
+ method interface: string -> signature -> string * signature
+ end
+
+val apply: source:string -> target:string -> #main_entry_points -> unit
+ (** Apply a mapper to a dumped parsetree found in the [source] file
+ and put the result in the [target] file. *)
+
+val main: #main_entry_points -> unit
+ (** Entry point to call to implement a standalone -ppx rewriter
+ from a mapper object. *)
+
+val run_main: (string list -> #main_entry_points) -> unit
+ (** Same as [main], but with extra arguments from the command line. *)
+
+(** {2 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> #mapper) -> unit
+
+ (** Apply the [register_function]. The default behavior is to run
+ the mapper immediately, taking arguments from the process
+ command line. This is to support a scenario where a mapper is
+ linked as a stand-alone executable.
+
+ It is possible to overwrite the [register_function] to define
+ "-ppx drivers", which combine several mappers in a single
+ process. Typically, a driver starts by defining
+ [register_function] to a custom implementation, then lets ppx
+ rewriters (linked statically or dynamically) register
+ themselves, and then run all or some of them. It is also
+ possible to have -ppx drivers apply rewriters to only specific
+ parts of an AST. *)
+
+
+(** {2 Helpers to build Parsetree fragments} *)
+
+module T:
+ sig
+ val mk: ?loc:Location.t -> core_type_desc -> core_type
+ val any: ?loc:Location.t -> unit -> core_type
+ val var: ?loc:Location.t -> string -> core_type
+ val arrow: ?loc:Location.t -> label -> core_type -> core_type -> core_type
+ val tuple: ?loc:Location.t -> core_type list -> core_type
+ val constr:
+ ?loc:Location.t -> Longident.t loc -> core_type list -> core_type
+ val object_: ?loc:Location.t -> core_field_type list -> core_type
+ val class_:
+ ?loc:Location.t -> Longident.t loc -> core_type list ->
+ label list -> core_type
+ val alias: ?loc:Location.t -> core_type -> string -> core_type
+ val variant:
+ ?loc:Location.t -> row_field list -> bool -> label list option ->
+ core_type
+ val poly: ?loc:Location.t -> string list -> core_type -> core_type
+ val package:
+ ?loc:Location.t -> Longident.t loc ->
+ (Longident.t loc * core_type) list -> core_type
+ val field_type: ?loc:Location.t -> core_field_desc -> core_field_type
+ val field: ?loc:Location.t -> string -> core_type -> core_field_type
+ val field_var: ?loc:Location.t -> unit -> core_field_type
+ val core_field_type: mapper -> core_field_type -> core_field_type
+ val row_field: mapper -> row_field -> row_field
+ val map: mapper -> core_type -> core_type
+ val map_type_declaration: mapper -> type_declaration -> type_declaration
+ val map_type_kind: mapper -> type_kind -> type_kind
+ end
+
+module CT:
+ sig
+ val mk: ?loc:Location.t -> class_type_desc -> class_type
+ val constr:
+ ?loc:Location.t -> Longident.t loc -> core_type list -> class_type
+ val signature: ?loc:Location.t -> class_signature -> class_type
+ val fun_: ?loc:Location.t -> label -> core_type -> class_type -> class_type
+ val map: mapper -> class_type -> class_type
+ val mk_field: ?loc:Location.t -> class_type_field_desc -> class_type_field
+ val inher: ?loc:Location.t -> class_type -> class_type_field
+ val val_:
+ ?loc:Location.t -> string -> mutable_flag -> virtual_flag ->
+ core_type -> class_type_field
+ val virt:
+ ?loc:Location.t -> string -> private_flag -> core_type ->
+ class_type_field
+ val meth:
+ ?loc:Location.t -> string -> private_flag -> core_type ->
+ class_type_field
+ val cstr: ?loc:Location.t -> core_type -> core_type -> class_type_field
+ val map_field: mapper -> class_type_field -> class_type_field
+ val map_signature: mapper -> class_signature -> class_signature
+ end
+
+module MT:
+ sig
+ val mk: ?loc:Location.t -> module_type_desc -> module_type
+ val ident: ?loc:Location.t -> Longident.t loc -> module_type
+ val signature: ?loc:Location.t -> signature -> module_type
+ val functor_:
+ ?loc:Location.t -> string loc -> module_type -> module_type ->
+ module_type
+ val with_:
+ ?loc:Location.t -> module_type ->
+ (Longident.t loc * with_constraint) list -> module_type
+ val typeof_: ?loc:Location.t -> module_expr -> module_type
+ val map: mapper -> module_type -> module_type
+ val map_with_constraint: mapper -> with_constraint -> with_constraint
+ val mk_item: ?loc:Location.t -> signature_item_desc -> signature_item
+ val value:
+ ?loc:Location.t -> string loc -> value_description -> signature_item
+ val type_:
+ ?loc:Location.t -> (string loc * type_declaration) list ->
+ signature_item
+ val exception_:
+ ?loc:Location.t -> string loc -> exception_declaration ->
+ signature_item
+ val module_: ?loc:Location.t -> string loc -> module_type -> signature_item
+ val rec_module:
+ ?loc:Location.t -> (string loc * module_type) list -> signature_item
+ val modtype:
+ ?loc:Location.t -> string loc -> modtype_declaration -> signature_item
+ val open_:
+ ?loc:Location.t -> override_flag -> Longident.t loc -> signature_item
+ val include_: ?loc:Location.t -> module_type -> signature_item
+ val class_: ?loc:Location.t -> class_description list -> signature_item
+ val class_type:
+ ?loc:Location.t -> class_type_declaration list -> signature_item
+ val map_signature_item: mapper -> signature_item -> signature_item
+ end
+
+module M:
+ sig
+ val mk: ?loc:Location.t -> module_expr_desc -> module_expr
+ val ident: ?loc:Location.t -> Longident.t loc -> module_expr
+ val structure: ?loc:Location.t -> structure -> module_expr
+ val functor_: ?loc:Location.t -> string loc -> module_type -> module_expr -> module_expr
+ val apply: ?loc:Location.t -> module_expr -> module_expr -> module_expr
+ val constraint_: ?loc:Location.t -> module_expr -> module_type -> module_expr
+ val unpack: ?loc:Location.t -> expression -> module_expr
+ val map: mapper -> module_expr -> module_expr
+ val mk_item: ?loc:Location.t -> structure_item_desc -> structure_item
+ val eval: ?loc:Location.t -> expression -> structure_item
+ val value: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> structure_item
+ val primitive: ?loc:Location.t -> string loc -> value_description -> structure_item
+ val type_: ?loc:Location.t -> (string loc * type_declaration) list -> structure_item
+ val exception_: ?loc:Location.t -> string loc -> exception_declaration -> structure_item
+ val exn_rebind: ?loc:Location.t -> string loc -> Longident.t loc -> structure_item
+ val module_: ?loc:Location.t -> string loc -> module_expr -> structure_item
+ val rec_module: ?loc:Location.t -> (string loc * module_type * module_expr) list -> structure_item
+ val modtype: ?loc:Location.t -> string loc -> module_type -> structure_item
+ val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> structure_item
+ val class_: ?loc:Location.t -> class_declaration list -> structure_item
+ val class_type: ?loc:Location.t -> class_type_declaration list -> structure_item
+ val include_: ?loc:Location.t -> module_expr -> structure_item
+ val map_structure_item: mapper -> structure_item -> structure_item
+ end
+
+module E:
+ sig
+ val mk: ?loc:Location.t -> expression_desc -> expression
+ val ident: ?loc:Location.t -> Longident.t loc -> expression
+ val constant: ?loc:Location.t -> constant -> expression
+ val let_: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> expression -> expression
+ val function_: ?loc:Location.t -> label -> expression option -> (pattern * expression) list -> expression
+ val apply: ?loc:Location.t -> expression -> (label * expression) list -> expression
+ val match_: ?loc:Location.t -> expression -> (pattern * expression) list -> expression
+ val try_: ?loc:Location.t -> expression -> (pattern * expression) list -> expression
+ val tuple: ?loc:Location.t -> expression list -> expression
+ val construct: ?loc:Location.t -> Longident.t loc -> expression option -> bool -> expression
+ val variant: ?loc:Location.t -> label -> expression option -> expression
+ val record: ?loc:Location.t -> (Longident.t loc * expression) list -> expression option -> expression
+ val field: ?loc:Location.t -> expression -> Longident.t loc -> expression
+ val setfield: ?loc:Location.t -> expression -> Longident.t loc -> expression -> expression
+ val array: ?loc:Location.t -> expression list -> expression
+ val ifthenelse: ?loc:Location.t -> expression -> expression -> expression option -> expression
+ val sequence: ?loc:Location.t -> expression -> expression -> expression
+ val while_: ?loc:Location.t -> expression -> expression -> expression
+ val for_: ?loc:Location.t -> string loc -> expression -> expression -> direction_flag -> expression -> expression
+ val constraint_: ?loc:Location.t -> expression -> core_type option -> core_type option -> expression
+ val when_: ?loc:Location.t -> expression -> expression -> expression
+ val send: ?loc:Location.t -> expression -> string -> expression
+ val new_: ?loc:Location.t -> Longident.t loc -> expression
+ val setinstvar: ?loc:Location.t -> string loc -> expression -> expression
+ val override: ?loc:Location.t -> (string loc * expression) list -> expression
+ val letmodule: ?loc:Location.t -> string loc * module_expr * expression -> expression
+ val assert_: ?loc:Location.t -> expression -> expression
+ val assertfalse: ?loc:Location.t -> unit -> expression
+ val lazy_: ?loc:Location.t -> expression -> expression
+ val poly: ?loc:Location.t -> expression -> core_type option -> expression
+ val object_: ?loc:Location.t -> class_structure -> expression
+ val newtype: ?loc:Location.t -> string -> expression -> expression
+ val pack: ?loc:Location.t -> module_expr -> expression
+ val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> expression -> expression
+ val lid: ?loc:Location.t -> string -> expression
+ val apply_nolabs: ?loc:Location.t -> expression -> expression list -> expression
+ val strconst: ?loc:Location.t -> string -> expression
+ val map: mapper -> expression -> expression
+ end
+
+module P:
+ sig
+ val mk: ?loc:Location.t -> pattern_desc -> pattern
+ val any: ?loc:Location.t -> unit -> pattern
+ val var: ?loc:Location.t -> string loc -> pattern
+ val alias: ?loc:Location.t -> pattern -> string loc -> pattern
+ val constant: ?loc:Location.t -> constant -> pattern
+ val tuple: ?loc:Location.t -> pattern list -> pattern
+ val construct: ?loc:Location.t -> Longident.t loc -> pattern option -> bool -> pattern
+ val variant: ?loc:Location.t -> label -> pattern option -> pattern
+ val record: ?loc:Location.t -> (Longident.t loc * pattern) list -> closed_flag -> pattern
+ val array: ?loc:Location.t -> pattern list -> pattern
+ val or_: ?loc:Location.t -> pattern -> pattern -> pattern
+ val constraint_: ?loc:Location.t -> pattern -> core_type -> pattern
+ val type_: ?loc:Location.t -> Longident.t loc -> pattern
+ val lazy_: ?loc:Location.t -> pattern -> pattern
+ val unpack: ?loc:Location.t -> string loc -> pattern
+ val map: mapper -> pattern -> pattern
+ end
+
+module CE:
+ sig
+ val mk: ?loc:Location.t -> class_expr_desc -> class_expr
+ val structure: ?loc:Location.t -> class_structure -> class_expr
+ val fun_: ?loc:Location.t -> label -> expression option -> pattern -> class_expr -> class_expr
+ val apply: ?loc:Location.t -> class_expr -> (label * expression) list -> class_expr
+ val let_: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr
+ val constraint_: ?loc:Location.t -> class_expr -> class_type -> class_expr
+ val map: mapper -> class_expr -> class_expr
+ val mk_field: ?loc:Location.t -> class_field_desc -> class_field
+ val inher: ?loc:Location.t -> override_flag -> class_expr -> string option -> class_field
+ val valvirt: ?loc:Location.t -> string loc -> mutable_flag -> core_type -> class_field
+ val val_: ?loc:Location.t -> string loc -> mutable_flag -> override_flag -> expression -> class_field
+ val virt: ?loc:Location.t -> string loc -> private_flag -> core_type -> class_field
+ val meth: ?loc:Location.t -> string loc -> private_flag -> override_flag -> expression -> class_field
+ val constr: ?loc:Location.t -> core_type -> core_type -> class_field
+ val init: ?loc:Location.t -> expression -> class_field
+ val map_field: mapper -> class_field -> class_field
+ val map_structure: mapper -> class_structure -> class_structure
+ val class_infos: mapper -> ('a -> 'b) -> 'a class_infos -> 'b class_infos
+ end
(* *)
(***********************************************************************)
-(* $Id: asttypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
type constant =
(* *)
(***********************************************************************)
-(* $Id: lexer.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* The lexical analyzer *)
val init : unit -> unit
(* *)
(***********************************************************************)
-(* $Id: lexer.mll 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* The lexer definition *)
{
let cvt_int64_literal s =
Int64.neg (Int64.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
let cvt_nativeint_literal s =
- Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+ Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0
+ (String.length s - 1)))
(* Remove underscores from float literals *)
| c -> s.[dst] <- c; remove (src + 1) (dst + 1)
in remove 0 0
+(* recover the name from a LABEL or OPTLABEL token *)
+
+let get_label_name lexbuf =
+ let s = Lexing.lexeme lexbuf in
+ let name = String.sub s 1 (String.length s - 2) in
+ if Hashtbl.mem keyword_table name then
+ raise (Error(Keyword_as_label name, Location.curr lexbuf));
+ name
+;;
+
(* Update the current location with file name and line number. *)
let update_loc lexbuf file line absolute chars =
}
;;
+(* Warn about Latin-1 characters used in idents *)
+
+let warn_latin1 lexbuf =
+ Location.prerr_warning (Location.curr lexbuf)
+ (Warnings.Deprecated "ISO-Latin1 characters in identifiers")
+;;
+
(* Error report *)
open Format
| Keyword_as_label kwd ->
fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
| Literal_overflow ty ->
- fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty
+ fprintf ppf "Integer literal exceeds the range of representable \
+ integers of type %s" ty
;;
}
-let newline = ('\010' | '\013' | "\013\010")
+let newline = ('\010' | "\013\010" )
let blank = [' ' '\009' '\012']
-let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
-let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
-let identchar =
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
| "~"
{ TILDE }
| "~" lowercase identchar * ':'
- { let s = Lexing.lexeme lexbuf in
- let name = String.sub s 1 (String.length s - 2) in
- if Hashtbl.mem keyword_table name then
- raise (Error(Keyword_as_label name, Location.curr lexbuf));
- LABEL name }
- | "?" { QUESTION }
- | "??" { QUESTIONQUESTION }
+ { LABEL (get_label_name lexbuf) }
+ | "~" lowercase_latin1 identchar_latin1 * ':'
+ { warn_latin1 lexbuf; LABEL (get_label_name lexbuf) }
+ | "?"
+ { QUESTION }
| "?" lowercase identchar * ':'
- { let s = Lexing.lexeme lexbuf in
- let name = String.sub s 1 (String.length s - 2) in
- if Hashtbl.mem keyword_table name then
- raise (Error(Keyword_as_label name, Location.curr lexbuf));
- OPTLABEL name }
+ { OPTLABEL (get_label_name lexbuf) }
+ | "?" lowercase_latin1 identchar_latin1 * ':'
+ { warn_latin1 lexbuf; OPTLABEL (get_label_name lexbuf) }
| lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
- try
- Hashtbl.find keyword_table s
- with Not_found ->
- LIDENT s }
+ try Hashtbl.find keyword_table s
+ with Not_found -> LIDENT s }
+ | lowercase_latin1 identchar_latin1 *
+ { warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) }
| uppercase identchar *
{ UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *)
+ | uppercase_latin1 identchar_latin1 *
+ { warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) }
| int_literal
{ try
INT (cvt_int_literal (Lexing.lexeme lexbuf))
let end_loc = comment lexbuf in
let s = get_stored_string () in
reset_string_buffer ();
- COMMENT (s, { start_loc with Location.loc_end = end_loc.Location.loc_end })
+ COMMENT (s, { start_loc with
+ Location.loc_end = end_loc.Location.loc_end })
}
| "(*)"
{ let loc = Location.curr lexbuf in
(* *)
(***********************************************************************)
-(* $Id: location.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Lexing
let absname = ref false
let line = ref 0 in
let pos_at_bol = ref 0 in
for pos = 0 to end_pos do
- let c = lb.lex_buffer.[pos + pos0] in
- if c <> '\n' then begin
- if !line = !line_start && !line = !line_end then
- (* loc is on one line: print whole line *)
- Format.pp_print_char ppf c
- else if !line = !line_start then
- (* first line of multiline loc: print ... before loc_start *)
- if pos < loc.loc_start.pos_cnum
- then Format.pp_print_char ppf '.'
- else Format.pp_print_char ppf c
- else if !line = !line_end then
- (* last line of multiline loc: print ... after loc_end *)
- if pos < loc.loc_end.pos_cnum
- then Format.pp_print_char ppf c
- else Format.pp_print_char ppf '.'
- else if !line > !line_start && !line < !line_end then
- (* intermediate line of multiline loc: print whole line *)
- Format.pp_print_char ppf c
- end else begin
+ match lb.lex_buffer.[pos + pos0] with
+ | '\n' ->
if !line = !line_start && !line = !line_end then begin
(* loc is on one line: underline location *)
Format.fprintf ppf "@. ";
- for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
+ for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
Format.pp_print_char ppf ' '
done;
- for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
+ for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
Format.pp_print_char ppf '^'
done
end;
if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " "
end;
incr line;
- pos_at_bol := pos + 1;
- end
+ pos_at_bol := pos + 1
+ | '\r' -> () (* discard *)
+ | c ->
+ if !line = !line_start && !line = !line_end then
+ (* loc is on one line: print whole line *)
+ Format.pp_print_char ppf c
+ else if !line = !line_start then
+ (* first line of multiline loc:
+ print a dot for each char before loc_start *)
+ if pos < loc.loc_start.pos_cnum then
+ Format.pp_print_char ppf '.'
+ else
+ Format.pp_print_char ppf c
+ else if !line = !line_end then
+ (* last line of multiline loc: print a dot for each char
+ after loc_end, even whitespaces *)
+ if pos < loc.loc_end.pos_cnum then
+ Format.pp_print_char ppf c
+ else
+ Format.pp_print_char ppf '.'
+ else if !line > !line_start && !line < !line_end then
+ (* intermediate line of multiline loc: print whole line *)
+ Format.pp_print_char ppf c
done
(* Highlight the location using one of the supported modes. *)
(* *)
(***********************************************************************)
-(* $Id: location.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Source code locations (ranges of positions), used in parsetree. *)
open Format
(* *)
(***********************************************************************)
-(* $Id: longident.ml 11252 2011-10-28 21:21:55Z weis $ *)
-
type t =
Lident of string
| Ldot of t * string
(* *)
(***********************************************************************)
-(* $Id: longident.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Long identifiers, used in parsetree. *)
type t =
(* *)
(***********************************************************************)
-(* $Id: parse.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Entry points in the parser *)
-open Location
-
(* Skip tokens to the end of the phrase *)
let rec skip_phrase lexbuf =
(* *)
(***********************************************************************)
-(* $Id: parse.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Entry points in the parser *)
val implementation : Lexing.lexbuf -> Parsetree.structure
/* */
/***********************************************************************/
-/* $Id: parser.mly 12800 2012-07-30 18:59:07Z doligez $ */
-
/* The parser definition */
%{
{ pcf_desc = d; pcf_loc = symbol_rloc () }
let mkrhs rhs pos = mkloc rhs (rhs_loc pos)
let mkoption d =
- { ptyp_desc = Ptyp_constr(mknoloc (Ldot (Lident "*predef*", "option")), [d]);
- ptyp_loc = d.ptyp_loc}
+ let loc = {d.ptyp_loc with loc_ghost = true} in
+ { ptyp_desc = Ptyp_constr(mkloc (Ldot (Lident "*predef*", "option")) loc,[d]);
+ ptyp_loc = loc}
let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
expressions and patterns that do not appear explicitly in the
source file they have the loc_ghost flag set to true.
Then the profiler will not try to instrument them and the
- -stypes option will not try to display their type.
+ -annot option will not try to display their type.
Every grammar rule that generates an element with a location must
make at most one non-ghost element, the topmost one.
let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };;
let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
+let ghloc d = { txt = d; loc = symbol_gloc () };;
let mkassert e =
match e with
| _ ->
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
-let mkexp_cons args loc =
- {pexp_desc = Pexp_construct(mkloc (Lident "::") Location.none,
- Some args, false); pexp_loc = loc}
+let mkexp_cons consloc args loc =
+ {pexp_desc = Pexp_construct(mkloc (Lident "::") consloc, Some args, false);
+ pexp_loc = loc}
-let mkpat_cons args loc =
- {ppat_desc = Ppat_construct(mkloc (Lident "::") Location.none,
- Some args, false); ppat_loc = loc}
+let mkpat_cons consloc args loc =
+ {ppat_desc = Ppat_construct(mkloc (Lident "::") consloc, Some args, false);
+ ppat_loc = loc}
-let rec mktailexp = function
+let rec mktailexp nilloc = function
[] ->
- ghexp(Pexp_construct(mkloc (Lident "[]") Location.none, None, false))
+ let loc = { nilloc with loc_ghost = true } in
+ let nil = { txt = Lident "[]"; loc = loc } in
+ { pexp_desc = Pexp_construct (nil, None, false); pexp_loc = loc }
| e1 :: el ->
- let exp_el = mktailexp el in
+ let exp_el = mktailexp nilloc el in
let l = {loc_start = e1.pexp_loc.loc_start;
loc_end = exp_el.pexp_loc.loc_end;
loc_ghost = true}
in
let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in
- mkexp_cons arg l
+ mkexp_cons {l with loc_ghost = true} arg l
-let rec mktailpat = function
+let rec mktailpat nilloc = function
[] ->
- ghpat(Ppat_construct(mkloc (Lident "[]") Location.none, None, false))
+ let loc = { nilloc with loc_ghost = true } in
+ let nil = { txt = Lident "[]"; loc = loc } in
+ { ppat_desc = Ppat_construct (nil, None, false); ppat_loc = loc }
| p1 :: pl ->
- let pat_pl = mktailpat pl in
+ let pat_pl = mktailpat nilloc pl in
let l = {loc_start = p1.ppat_loc.loc_start;
loc_end = pat_pl.ppat_loc.loc_end;
loc_ghost = true}
in
let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
- mkpat_cons arg l
+ mkpat_cons {l with loc_ghost = true} arg l
-let ghstrexp e =
- { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
+let mkstrexp e =
+ { pstr_desc = Pstr_eval e; pstr_loc = e.pexp_loc }
let array_function str name =
- mknoloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
+ ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
let rec deep_mkrangepat c1 c2 =
if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else
raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name,
rhs_loc closing_num, closing_name)))
+let expecting pos nonterm =
+ raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))
+
let bigarray_function str name =
- mkloc (Ldot(Ldot(Lident "Bigarray", str), name)) Location.none
+ ghloc (Ldot(Ldot(Lident "Bigarray", str), name))
let bigarray_untuplify = function
{ pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
%token <string> PREFIXOP
%token PRIVATE
%token QUESTION
-%token QUESTIONQUESTION
%token QUOTE
%token RBRACE
%token RBRACKET
;
toplevel_phrase:
top_structure SEMISEMI { Ptop_def $1 }
- | seq_expr SEMISEMI { Ptop_def[ghstrexp $1] }
+ | seq_expr SEMISEMI { Ptop_def[mkstrexp $1] }
| toplevel_directive SEMISEMI { $1 }
| EOF { raise End_of_file }
;
;
use_file:
use_file_tail { $1 }
- | seq_expr use_file_tail { Ptop_def[ghstrexp $1] :: $2 }
+ | seq_expr use_file_tail { Ptop_def[mkstrexp $1] :: $2 }
;
use_file_tail:
EOF { [] }
| SEMISEMI EOF { [] }
- | SEMISEMI seq_expr use_file_tail { Ptop_def[ghstrexp $2] :: $3 }
+ | SEMISEMI seq_expr use_file_tail { Ptop_def[mkstrexp $2] :: $3 }
| SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
| SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
| structure_item use_file_tail { Ptop_def[$1] :: $2 }
;
structure:
structure_tail { $1 }
- | seq_expr structure_tail { ghstrexp $1 :: $2 }
+ | seq_expr structure_tail { mkstrexp $1 :: $2 }
;
structure_tail:
/* empty */ { [] }
| SEMISEMI { [] }
- | SEMISEMI seq_expr structure_tail { ghstrexp $2 :: $3 }
+ | SEMISEMI seq_expr structure_tail { mkstrexp $2 :: $3 }
| SEMISEMI structure_item structure_tail { $2 :: $3 }
| structure_item structure_tail { $1 :: $2 }
;
{ mkstr(Pstr_recmodule(List.rev $3)) }
| MODULE TYPE ident EQUAL module_type
{ mkstr(Pstr_modtype(mkrhs $3 3, $5)) }
- | OPEN mod_longident
- { mkstr(Pstr_open (mkrhs $2 2)) }
+ | OPEN override_flag mod_longident
+ { mkstr(Pstr_open ($2, mkrhs $3 3)) }
| CLASS class_declarations
{ mkstr(Pstr_class (List.rev $2)) }
| CLASS TYPE class_type_declarations
{ mksig(Psig_modtype(mkrhs $3 3, Pmodtype_abstract)) }
| MODULE TYPE ident EQUAL module_type
{ mksig(Psig_modtype(mkrhs $3 3, Pmodtype_manifest $5)) }
- | OPEN mod_longident
- { mksig(Psig_open (mkrhs $2 2)) }
+ | OPEN override_flag mod_longident
+ { mksig(Psig_open ($2, mkrhs $3 3)) }
| INCLUDE module_type
{ mksig(Psig_include $2) }
| CLASS class_descriptions
override_flag mutable_flag label EQUAL seq_expr
{ mkrhs $3 3, $2, $1, $5 }
| override_flag mutable_flag label type_constraint EQUAL seq_expr
- { mkrhs $3 3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))) },
+ { let (t, t') = $4 in
+ mkrhs $3 3, $2, $1, ghexp(Pexp_constraint($6, t, t')) }
;
virtual_method:
METHOD override_flag PRIVATE VIRTUAL label COLON poly_type
{ mkexp(Pexp_let($2, List.rev $3, $5)) }
| LET MODULE UIDENT module_binding IN seq_expr
{ mkexp(Pexp_letmodule(mkrhs $3 3, $4, $6)) }
- | LET OPEN mod_longident IN seq_expr
- { mkexp(Pexp_open(mkrhs $3 3, $5)) }
+ | LET OPEN override_flag mod_longident IN seq_expr
+ { mkexp(Pexp_open($3, mkrhs $4 4, $6)) }
| FUNCTION opt_bar match_cases
{ mkexp(Pexp_function("", None, List.rev $3)) }
| FUN labeled_simple_pattern fun_def
| FOR val_ident EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE
{ mkexp(Pexp_for(mkrhs $2 2, $4, $6, $5, $8)) }
| expr COLONCOLON expr
- { mkexp_cons (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
+ { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
| LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
- { mkexp_cons (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
+ { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
| expr INFIXOP0 expr
{ mkinfix $1 $2 $3 }
| expr INFIXOP1 expr
| BEGIN seq_expr END
{ reloc_exp $2 }
| BEGIN END
- { mkexp (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()), None, false)) }
+ { mkexp (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()),
+ None, false)) }
| BEGIN seq_expr error
{ unclosed "begin" 1 "end" 3 }
| LPAREN seq_expr type_constraint RPAREN
| simple_expr DOT label_longident
{ mkexp(Pexp_field($1, mkrhs $3 3)) }
| mod_longident DOT LPAREN seq_expr RPAREN
- { mkexp(Pexp_open(mkrhs $1 1, $4)) }
+ { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) }
| mod_longident DOT LPAREN seq_expr error
{ unclosed "(" 3 ")" 5 }
| simple_expr DOT LPAREN seq_expr RPAREN
| LBRACKETBAR BARRBRACKET
{ mkexp(Pexp_array []) }
| LBRACKET expr_semi_list opt_semi RBRACKET
- { reloc_exp (mktailexp (List.rev $2)) }
+ { reloc_exp (mktailexp (rhs_loc 4) (List.rev $2)) }
| LBRACKET expr_semi_list opt_semi error
{ unclosed "[" 1 "]" 4 }
| PREFIXOP simple_expr
val_ident fun_binding
{ (mkpatvar $1 1, $2) }
| val_ident COLON typevar_list DOT core_type EQUAL seq_expr
- { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) }
+ { (ghpat(Ppat_constraint(mkpatvar $1 1,
+ ghtyp(Ptyp_poly(List.rev $3,$5)))),
+ $7) }
| val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
{ let exp, poly = wrap_type_annotation $4 $6 $8 in
(ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
;
match_action:
MINUSGREATER seq_expr { $2 }
- | WHEN seq_expr MINUSGREATER seq_expr { mkexp(Pexp_when($2, $4)) }
+ | WHEN seq_expr MINUSGREATER seq_expr { ghexp(Pexp_when($2, $4)) }
;
expr_comma_list:
expr_comma_list COMMA expr { $3 :: $1 }
{ $1 }
| pattern AS val_ident
{ mkpat(Ppat_alias($1, mkrhs $3 3)) }
+ | pattern AS error
+ { expecting 3 "identifier" }
| pattern_comma_list %prec below_COMMA
{ mkpat(Ppat_tuple(List.rev $1)) }
| constr_longident pattern %prec prec_constr_appl
| name_tag pattern %prec prec_constr_appl
{ mkpat(Ppat_variant($1, Some $2)) }
| pattern COLONCOLON pattern
- { mkpat_cons (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) },
+ { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
+ | pattern COLONCOLON error
+ { expecting 3 "pattern" }
| LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
- { mkpat_cons (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+ { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+ | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
+ { unclosed "(" 4 ")" 8 }
| pattern BAR pattern
{ mkpat(Ppat_or($1, $3)) }
+ | pattern BAR error
+ { expecting 3 "pattern" }
| LAZY simple_pattern
{ mkpat(Ppat_lazy $2) }
;
| LBRACE lbl_pattern_list RBRACE
{ let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
| LBRACE lbl_pattern_list error
- { unclosed "{" 1 "}" 4 }
+ { unclosed "{" 1 "}" 3 }
| LBRACKET pattern_semi_list opt_semi RBRACKET
- { reloc_pat (mktailpat (List.rev $2)) }
+ { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
| LBRACKET pattern_semi_list opt_semi error
{ unclosed "[" 1 "]" 4 }
| LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
{ mkpat(Ppat_constraint($2, $4)) }
| LPAREN pattern COLON core_type error
{ unclosed "(" 1 ")" 5 }
+ | LPAREN pattern COLON error
+ { expecting 4 "type" }
| LPAREN MODULE UIDENT RPAREN
{ mkpat(Ppat_unpack (mkrhs $3 3)) }
| LPAREN MODULE UIDENT COLON package_type RPAREN
- { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),ghtyp(Ptyp_package $5))) }
+ { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),
+ ghtyp(Ptyp_package $5))) }
| LPAREN MODULE UIDENT COLON package_type error
{ unclosed "(" 1 ")" 6 }
;
pattern_comma_list:
pattern_comma_list COMMA pattern { $3 :: $1 }
| pattern COMMA pattern { [$3; $1] }
+ | pattern COMMA error { expecting 3 "pattern" }
;
pattern_semi_list:
pattern { [$1] }
| pattern_semi_list SEMI pattern { $3 :: $1 }
;
lbl_pattern_list:
- lbl_pattern { [$1], Closed }
- | lbl_pattern SEMI { [$1], Closed }
- | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open }
- | lbl_pattern SEMI lbl_pattern_list { let (fields, closed) = $3 in $1 :: fields, closed }
+ lbl_pattern { [$1], Closed }
+ | lbl_pattern SEMI { [$1], Closed }
+ | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open }
+ | lbl_pattern SEMI lbl_pattern_list
+ { let (fields, closed) = $3 in $1 :: fields, closed }
;
lbl_pattern:
label_longident EQUAL pattern
| label_declarations SEMI label_declaration { $3 :: $1 }
;
label_declaration:
- mutable_flag label COLON poly_type { (mkrhs $2 2, $1, $4, symbol_rloc()) }
+ mutable_flag label COLON poly_type
+ { (mkrhs $2 2, $1, $4, symbol_rloc()) }
;
/* "with" constraints (additional type equations over signature components) */
with_constraint:
TYPE type_parameters label_longident with_type_binder core_type constraints
{ let params, variance = List.split $2 in
- (mkrhs $3 3, Pwith_type {ptype_params = List.map (fun x -> Some x) params;
- ptype_cstrs = List.rev $6;
- ptype_kind = Ptype_abstract;
- ptype_manifest = Some $5;
- ptype_private = $4;
- ptype_variance = variance;
- ptype_loc = symbol_rloc()}) }
+ (mkrhs $3 3,
+ Pwith_type {ptype_params = List.map (fun x -> Some x) params;
+ ptype_cstrs = List.rev $6;
+ ptype_kind = Ptype_abstract;
+ ptype_manifest = Some $5;
+ ptype_private = $4;
+ ptype_variance = variance;
+ ptype_loc = symbol_rloc()}) }
/* used label_longident instead of type_longident to disallow
functor applications in type path */
- | TYPE type_parameters label_longident COLONEQUAL core_type
+ | TYPE type_parameters label COLONEQUAL core_type
{ let params, variance = List.split $2 in
- (mkrhs $3 3, Pwith_typesubst {ptype_params = List.map (fun x -> Some x) params;
- ptype_cstrs = [];
- ptype_kind = Ptype_abstract;
- ptype_manifest = Some $5;
- ptype_private = Public;
- ptype_variance = variance;
- ptype_loc = symbol_rloc()}) }
+ (mkrhs (Lident $3) 3,
+ Pwith_typesubst { ptype_params = List.map (fun x -> Some x) params;
+ ptype_cstrs = [];
+ ptype_kind = Ptype_abstract;
+ ptype_manifest = Some $5;
+ ptype_private = Public;
+ ptype_variance = variance;
+ ptype_loc = symbol_rloc()}) }
| MODULE mod_longident EQUAL mod_ext_longident
{ (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
- | MODULE mod_longident COLONEQUAL mod_ext_longident
- { (mkrhs $2 2, Pwith_modsubst (mkrhs $4 4)) }
+ | MODULE UIDENT COLONEQUAL mod_ext_longident
+ { (mkrhs (Lident $2) 2, Pwith_modsubst (mkrhs $4 4)) }
;
with_type_binder:
EQUAL { Public }
| LBRACKET tag_field RBRACKET
{ mktyp(Ptyp_variant([$2], true, None)) }
/* PR#3835: this is not LR(1), would need lookahead=2
- | LBRACKET simple_core_type2 RBRACKET
+ | LBRACKET simple_core_type RBRACKET
{ mktyp(Ptyp_variant([$2], true, None)) }
*/
| LBRACKET BAR row_field_list RBRACKET
;
row_field:
tag_field { $1 }
- | simple_core_type2 { Rinherit $1 }
+ | simple_core_type { Rinherit $1 }
;
tag_field:
name_tag OF opt_ampersand amper_type_list
| NATIVEINT { Const_nativeint $1 }
;
signed_constant:
- constant { $1 }
- | MINUS INT { Const_int(- $2) }
- | MINUS FLOAT { Const_float("-" ^ $2) }
- | MINUS INT32 { Const_int32(Int32.neg $2) }
- | MINUS INT64 { Const_int64(Int64.neg $2) }
- | MINUS NATIVEINT { Const_nativeint(Nativeint.neg $2) }
- | PLUS INT { Const_int $2 }
- | PLUS FLOAT { Const_float $2 }
- | PLUS INT32 { Const_int32 $2 }
- | PLUS INT64 { Const_int64 $2 }
- | PLUS NATIVEINT { Const_nativeint $2 }
+ constant { $1 }
+ | MINUS INT { Const_int(- $2) }
+ | MINUS FLOAT { Const_float("-" ^ $2) }
+ | MINUS INT32 { Const_int32(Int32.neg $2) }
+ | MINUS INT64 { Const_int64(Int64.neg $2) }
+ | MINUS NATIVEINT { Const_nativeint(Nativeint.neg $2) }
+ | PLUS INT { Const_int $2 }
+ | PLUS FLOAT { Const_float $2 }
+ | PLUS INT32 { Const_int32 $2 }
+ | PLUS INT64 { Const_int64 $2 }
+ | PLUS NATIVEINT { Const_nativeint $2 }
;
/* Identifiers and long identifiers */
val_ident:
LIDENT { $1 }
| LPAREN operator RPAREN { $2 }
+ | LPAREN operator error { unclosed "(" 1 ")" 3 }
+ | LPAREN error { expecting 2 "operator" }
+ | LPAREN MODULE error { expecting 3 "module-expr" }
;
operator:
PREFIXOP { $1 }
| LPAREN RPAREN { Lident "()" }
| FALSE { Lident "false" }
| TRUE { Lident "true" }
+;
/* Toplevel directives */
(* *)
(***********************************************************************)
-(* $Id: parsetree.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Abstract syntax tree produced by parsing *)
open Asttypes
| Pexp_ifthenelse of expression * expression * expression option
| Pexp_sequence of expression * expression
| Pexp_while of expression * expression
- | Pexp_for of string loc * expression * expression * direction_flag * expression
+ | Pexp_for of
+ string loc * expression * expression * direction_flag * expression
| Pexp_constraint of expression * core_type option * core_type option
| Pexp_when of expression * expression
| Pexp_send of expression * string
| Pexp_object of class_structure
| Pexp_newtype of string * expression
| Pexp_pack of module_expr
- | Pexp_open of Longident.t loc * expression
+ | Pexp_open of override_flag * Longident.t loc * expression
(* Value descriptions *)
and value_description =
{ pval_type: core_type;
pval_prim: string list;
- pval_loc : Location.t
+ pval_loc: Location.t
}
(* Type declarations *)
| Pcty_fun of label * core_type * class_type
and class_signature = {
- pcsig_self : core_type;
- pcsig_fields : class_type_field list;
- pcsig_loc : Location.t;
+ pcsig_self: core_type;
+ pcsig_fields: class_type_field list;
+ pcsig_loc: Location.t;
}
and class_type_field = {
- pctf_desc : class_type_field_desc;
- pctf_loc : Location.t;
+ pctf_desc: class_type_field_desc;
+ pctf_loc: Location.t;
}
and class_type_field_desc =
| Pcl_constraint of class_expr * class_type
and class_structure = {
- pcstr_pat : pattern;
- pcstr_fields : class_field list;
+ pcstr_pat: pattern;
+ pcstr_fields: class_field list;
}
and class_field = {
- pcf_desc : class_field_desc;
- pcf_loc : Location.t;
+ pcf_desc: class_field_desc;
+ pcf_loc: Location.t;
}
and class_field_desc =
Pcf_inher of override_flag * class_expr * string option
| Pcf_valvirt of (string loc * mutable_flag * core_type)
| Pcf_val of (string loc * mutable_flag * override_flag * expression)
- | Pcf_virt of (string loc * private_flag * core_type)
- | Pcf_meth of (string loc * private_flag *override_flag * expression)
- | Pcf_constr of (core_type * core_type)
- | Pcf_init of expression
+ | Pcf_virt of (string loc * private_flag * core_type)
+ | Pcf_meth of (string loc * private_flag * override_flag * expression)
+ | Pcf_constr of (core_type * core_type)
+ | Pcf_init of expression
and class_declaration = class_expr class_infos
| Psig_module of string loc * module_type
| Psig_recmodule of (string loc * module_type) list
| Psig_modtype of string loc * modtype_declaration
- | Psig_open of Longident.t loc
+ | Psig_open of override_flag * Longident.t loc
| Psig_include of module_type
| Psig_class of class_description list
| Psig_class_type of class_type_declaration list
| Pstr_module of string loc * module_expr
| Pstr_recmodule of (string loc * module_type * module_expr) list
| Pstr_modtype of string loc * module_type
- | Pstr_open of Longident.t loc
+ | Pstr_open of override_flag * Longident.t loc
| Pstr_class of class_declaration list
| Pstr_class_type of class_type_declaration list
| Pstr_include of module_expr
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
+(* Hongbo Zhang (University of Pennsylvania) *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors: Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+
+let prefix_symbols = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+ '$'; '%' ]
+let operator_chars = [ '!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/';
+ ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~' ]
+let numeric_chars = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ]
+
+(* type fixity = Infix| Prefix *)
+
+
+let special_infix_strings =
+ ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ]
+
+(* determines if the string is an infix string.
+ checks backwards, first allowing a renaming postfix ("_102") which
+ may have resulted from Pexp -> Texp -> Pexp translation, then checking
+ if all the characters in the beginning of the string are valid infix
+ characters. *)
+let fixity_of_string = function
+ | s when List.mem s special_infix_strings -> `Infix s
+ | s when List.mem s.[0] infix_symbols -> `Infix s
+ | s when List.mem s.[0] prefix_symbols -> `Prefix s
+ | _ -> `Normal
+
+let view_fixity_of_exp = function
+ | {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
+ | _ -> `Normal ;;
+
+let is_infix = function | `Infix _ -> true | _ -> false
+
+let is_predef_option = function
+ | (Ldot (Lident "*predef*","option")) -> true
+ | _ -> false
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+ | Override -> "!"
+ | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+ | (false,false) -> ""
+ | (true,false) -> "+"
+ | (false,true) -> "-"
+ | (_,_) -> assert false
+
+type construct =
+ [ `cons of expression list
+ | `list of expression list
+ | `nil
+ | `normal
+ | `simple of Longident.t
+ | `tuple ]
+
+let view_expr x =
+ match x.pexp_desc with
+ | Pexp_construct ( {txt= Lident "()"; _},_,_) -> `tuple
+ | Pexp_construct ( {txt= Lident "[]";_},_,_) -> `nil
+ | Pexp_construct ( {txt= Lident"::";_},Some _,_) ->
+ let rec loop exp acc = match exp with
+ | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_,_);_} ->
+ (List.rev acc,true)
+ | {pexp_desc=
+ Pexp_construct ({txt=Lident "::";_},
+ Some ({pexp_desc= Pexp_tuple([e1;e2]);_}),_);_} ->
+ loop e2 (e1::acc)
+ | e -> (List.rev (e::acc),false) in
+ let (ls,b) = loop x [] in
+ if b then
+ `list ls
+ else `cons ls
+ | Pexp_construct (x,None,_) -> `simple (x.txt)
+ | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+ | `nil | `tuple | `list _ | `simple _ -> true
+ | `cons _ | `normal -> false
+
+let pp = fprintf
+
+let rec is_irrefut_patt x =
+ match x.ppat_desc with
+ | Ppat_any | Ppat_var _ | Ppat_unpack _ -> true
+ | Ppat_alias (p,_) -> is_irrefut_patt p
+ | Ppat_tuple (ps) -> List.for_all is_irrefut_patt ps
+ | Ppat_constraint (p,_) -> is_irrefut_patt p
+ | Ppat_or (l,r) -> is_irrefut_patt l || is_irrefut_patt r
+ | Ppat_record (ls,_) -> List.for_all (fun (_,x) -> is_irrefut_patt x) ls
+ | Ppat_lazy p -> is_irrefut_patt p
+ | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ | Ppat_array _
+ | Ppat_type _ -> false (*conservative*)
+class printer ()= object(self:'self)
+ val pipe = false
+ val semi = false
+ val ifthenelse = false
+ method under_pipe = {<pipe=true>}
+ method under_semi = {<semi=true>}
+ method under_ifthenelse = {<ifthenelse=true>}
+ method reset_semi = {<semi=false>}
+ method reset_ifthenelse = {<ifthenelse=false>}
+ method reset_pipe = {<pipe=false>}
+ method reset = {<pipe=false;semi=false;ifthenelse=false>}
+ method list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+ ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+ Format.formatter -> 'a list -> unit
+ = fun ?sep ?first ?last fu f xs ->
+ let first = match first with Some x -> x |None -> ""
+ and last = match last with Some x -> x |None -> ""
+ and sep = match sep with Some x -> x |None -> "@ " in
+ let aux f = function
+ | [] -> ()
+ | [x] -> fu f x
+ | xs ->
+ let rec loop f = function
+ | [x] -> fu f x
+ | x::xs -> pp f "%a%(%)%a" fu x sep loop xs
+ | _ -> assert false in begin
+ pp f "%(%)%a%(%)" first loop xs last;
+ end in
+ aux f xs
+ method option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+ (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit =
+ fun ?first ?last fu f a ->
+ let first = match first with Some x -> x | None -> ""
+ and last = match last with Some x -> x | None -> "" in
+ match a with
+ | None -> ()
+ | Some x -> pp f "%(%)%a%(%)" first fu x last
+ method paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+ bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit =
+ fun ?(first="") ?(last="") b fu f x ->
+ if b then pp f "(%(%)%a%(%))" first fu x last
+ else fu f x
+
+
+ method longident f = function
+ | Lident s ->
+ (match s.[0] with
+ | 'a' .. 'z' | 'A' .. 'Z' | '_'
+ when not (is_infix (fixity_of_string s)) ->
+ pp f "%s" s
+ | _ -> pp f "(@;%s@;)" s )
+ | Ldot(y,s) -> (match s.[0] with
+ | 'a'..'z' | 'A' .. 'Z' | '_' when not(is_infix (fixity_of_string s)) ->
+ pp f "%a.%s" self#longident y s
+ | _ ->
+ pp f "%a.(@;%s@;)@ " self#longident y s)
+ | Lapply (y,s) ->
+ pp f "%a(%a)" self#longident y self#longident s
+ method longident_loc f x = pp f "%a" self#longident x.txt
+ method constant f = function
+ | Const_char i -> pp f "%C" i
+ | Const_string i -> pp f "%S" i
+ | Const_int i -> self#paren (i<0) (fun f -> pp f "%d") f i
+ | Const_float i -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
+ | Const_int32 i -> self#paren (i<0l) (fun f -> pp f "%ldl") f i
+ | Const_int64 i -> self#paren (i<0L) (fun f -> pp f "%LdL") f i
+ (* pp f "%LdL" i *)
+ | Const_nativeint i -> self#paren (i<0n) (fun f -> pp f "%ndn") f i
+ (* pp f "%ndn" i *)
+
+ (* trailing space*)
+ method mutable_flag f = function
+ | Immutable -> ()
+ | Mutable -> pp f "mutable@;"
+ method virtual_flag f = function
+ | Concrete -> ()
+ | Virtual -> pp f "virtual@;"
+
+ (* trailing space added *)
+ method rec_flag f = function
+ | Nonrecursive -> ()
+ | Recursive | Default -> pp f "rec "
+ method direction_flag f = function
+ | Upto -> pp f "to@ "
+ | Downto -> pp f "downto@ "
+ method private_flag f = function
+ | Public -> ()
+ | Private -> pp f "private@ "
+
+ method constant_string f s = pp f "%S" s
+ method tyvar f str = pp f "'%s" str
+ method string_quot f x = pp f "`%s" x
+ method type_var_option f str =
+ match str with
+ | None -> pp f "_" (* wildcard*)
+ | Some {txt;_} -> self#tyvar f txt
+
+ (* c ['a,'b] *)
+ method class_params_def f = function
+ | [] -> ()
+ | l ->
+ pp f "[%a] " (* space *)
+ (self#list (fun f ({txt;_},s) ->
+ pp f "%s%a" (type_variance s) self#tyvar txt) ~sep:",") l
+
+ method type_with_label f (label,({ptyp_desc;_}as c) ) =
+ match label with
+ | "" -> self#core_type1 f c (* otherwise parenthesize *)
+ | s ->
+ if s.[0]='?' then
+ match ptyp_desc with
+ | Ptyp_constr ({txt;_}, l) ->
+ assert (is_predef_option txt);
+ pp f "%s:%a" s (self#list self#core_type1) l
+ | _ -> failwith "invalid input in print_type_with_label"
+ else pp f "%s:%a" s self#core_type1 c
+ method core_type f x =
+ match x.ptyp_desc with
+ | Ptyp_arrow (l, ct1, ct2) ->
+ pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+ self#type_with_label (l,ct1) self#core_type ct2
+ | Ptyp_alias (ct, s) ->
+ pp f "@[<2>%a@;as@;'%s@]" self#core_type1 ct s
+ | Ptyp_poly (sl, ct) ->
+ pp f "@[<2>%a%a@]"
+ (fun f l ->
+ pp f "%a"
+ (fun f l -> match l with
+ | [] -> ()
+ | _ ->
+ pp f "%a@;.@;"
+ (self#list self#tyvar ~sep:"@;") l)
+ l)
+ sl self#core_type ct
+ | _ -> pp f "@[<2>%a@]" self#core_type1 x
+ method core_type1 f x =
+ match x.ptyp_desc with
+ | Ptyp_any -> pp f "_";
+ | Ptyp_var s -> self#tyvar f s;
+ | Ptyp_tuple l -> pp f "(%a)" (self#list self#core_type1 ~sep:"*@;") l
+ | Ptyp_constr (li, l) ->
+ pp f (* "%a%a@;" *) "%a%a"
+ (fun f l -> match l with
+ |[] -> ()
+ |[x]-> pp f "%a@;" self#core_type1 x
+ | _ -> self#list ~first:"(" ~last:")@;" self#core_type ~sep:"," f l)
+ l self#longident_loc li
+ | Ptyp_variant (l, closed, low) ->
+ let type_variant_helper f x =
+ match x with
+ | Rtag (l, _, ctl) -> pp f "@[<2>%a%a@]" self#string_quot l
+ (fun f l -> match l with
+ |[] -> ()
+ | _ -> pp f "@;of@;%a"
+ (self#list self#core_type ~sep:"&") ctl) ctl
+ | Rinherit ct -> self#core_type f ct in
+ pp f "@[<2>[%a%a]@]"
+ (fun f l
+ ->
+ match l with
+ | [] -> ()
+ | _ ->
+ pp f "%s@;%a"
+ (match (closed,low) with
+ | (true,None) -> ""
+ | (true,Some _) -> "<" (* FIXME desugar the syntax sugar *)
+ | (false,_) -> ">")
+ (self#list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+ (fun f low
+ ->
+ match low with
+ |Some [] |None -> ()
+ |Some xs ->
+ pp f ">@ %a"
+ (self#list self#string_quot) xs) low
+ | Ptyp_object l ->
+ let core_field_type f {pfield_desc;_} =
+ match pfield_desc with
+ | Pfield (s, ct) ->
+ pp f "@[<hov2>%s@ :%a@ @]" s self#core_type ct
+ | Pfield_var -> pp f ".." in
+ pp f "@[<hov2><@ %a@ >@]" (self#list core_field_type ~sep:";") l
+ | Ptyp_class (li, l, low) -> (*FIXME*)
+ pp f "@[<hov2>%a#%a%a@]"
+ (self#list self#core_type ~sep:"," ~first:"(" ~last:")") l
+ self#longident_loc li
+ (fun f low -> match low with
+ | [] -> ()
+ | _ -> pp f "@ [>@ %a]" (self#list self#string_quot) low) low
+ | Ptyp_package (lid, cstrs) ->
+ let aux f (s, ct) =
+ pp f "type %a@ =@ %a" self#longident_loc s self#core_type ct in
+ (match cstrs with
+ |[] -> pp f "@[<hov2>(module@ %a)@]" self#longident_loc lid
+ |_ ->
+ pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid
+ (self#list aux ~sep:"@ and@ ") cstrs)
+ | _ -> self#paren true self#core_type f x
+ (********************pattern********************)
+ (* be cautious when use [pattern], [pattern1] is preferred *)
+ method pattern f x =
+ let rec pattern_or_helper cur = function
+ |{ppat_desc = Ppat_constant (Const_char a);_}
+ ->
+ if Char.code a = Char.code cur + 1 then
+ Some a
+ else None
+ |{ppat_desc =
+ Ppat_or({ppat_desc=Ppat_constant (Const_char a);_}, p2);_} ->
+ if Char.code a = Char.code cur + 1 then
+ pattern_or_helper a p2
+ else None
+ | _ -> None in
+ let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
+ | {ppat_desc= Ppat_or (p1,p2);_} ->
+ list_of_pattern (p2::acc) p1
+ | x -> x::acc in
+ match x.ppat_desc with
+ | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]"
+ self#pattern p
+ (fun f s->
+ if is_infix (fixity_of_string s.txt)
+ || List.mem s.txt.[0] prefix_symbols
+ then pp f "( %s )" s.txt
+ else pp f "%s" s.txt ) s (* RA*)
+ | Ppat_or (p1, p2) -> (* *)
+ (match p1 with
+ | {ppat_desc=Ppat_constant (Const_char a);_} ->
+ (match pattern_or_helper a p2 with
+ |Some b -> pp f "@[<2>%C..%C@]" a b
+ |None ->
+ pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern)
+ (list_of_pattern [] x))
+ | _ ->
+ pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern)
+ (list_of_pattern [] x)
+ )
+ | _ -> self#pattern1 f x
+ method pattern1 (f:Format.formatter) (x:pattern) :unit =
+ let rec pattern_list_helper f = function
+ | {ppat_desc =
+ Ppat_construct
+ ({ txt = Lident("::") ;_},
+ Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_}),
+ _);_} ->
+ pp f "%a::%a" self#simple_pattern pat1 pattern_list_helper pat2 (*RA*)
+ | p -> self#pattern1 f p in
+ match x.ppat_desc with
+ | Ppat_variant (l, Some p) -> pp f "@[<2>`%s@;%a@]" l self#pattern1 p (*RA*)
+ | Ppat_construct (({txt=Lident("()"|"[]");_}), _, _) -> self#simple_pattern f x
+ | Ppat_construct (({txt;_} as li), po, _) -> (* FIXME The third field always false *)
+ if txt = Lident "::" then
+ pp f "%a" pattern_list_helper x
+ else
+ (match po with
+ |Some x ->
+ pp f "%a@;%a" self#longident_loc li self#simple_pattern x
+ | None -> pp f "%a@;"self#longident_loc li )
+ | _ -> self#simple_pattern f x
+ method simple_pattern (f:Format.formatter) (x:pattern) :unit =
+ match x.ppat_desc with
+ | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _, _) -> pp f "%s" x
+ | Ppat_any -> pp f "_";
+ | Ppat_var ({txt = txt;_}) ->
+ if (is_infix (fixity_of_string txt)) || List.mem txt.[0] prefix_symbols then
+ if txt.[0]='*' || txt.[String.length txt - 1] = '*' then
+ pp f "(@;%s@;)@ " txt
+ else
+ pp f "(%s)" txt
+ else
+ pp f "%s" txt
+ | Ppat_array l ->
+ pp f "@[<2>[|%a|]@]" (self#list self#pattern1 ~sep:";") l
+ | Ppat_unpack (s) ->
+ pp f "(module@ %s)@ " s.txt
+ | Ppat_type li ->
+ pp f "#%a" self#longident_loc li
+ | Ppat_record (l, closed) ->
+ let longident_x_pattern f (li, p) =
+ match (li,p.ppat_desc) with
+ | ({txt=Lident s;_ },Ppat_var {txt;_} ) when s = txt ->
+ pp f "@[<2>%a@]" self#longident_loc li
+ | _ ->
+ pp f "@[<2>%a@;=@;%a@]" self#longident_loc li self#pattern1 p in
+ (match closed with
+ |Closed ->
+ pp f "@[<2>{@;%a@;}@]"
+ (self#list longident_x_pattern ~sep:";@;") l
+ | _ ->
+ pp f "@[<2>{@;%a;_}@]"
+ (self#list longident_x_pattern ~sep:";@;") l)
+ | Ppat_tuple l -> pp f "@[<1>(%a)@]" (self#list ~sep:"," self#pattern1) l (* level1*)
+ | Ppat_constant (c) -> pp f "%a" self#constant c
+ | Ppat_variant (l,None) -> pp f "`%s" l
+ | Ppat_constraint (p, ct) ->
+ pp f "@[<2>(%a@;:@;%a)@]" self#pattern1 p self#core_type ct
+ | Ppat_lazy p ->
+ pp f "@[<2>(lazy@;%a)@]" self#pattern1 p
+ | _ -> self#paren true self#pattern f x
+
+ method label_exp f (l,opt,p) =
+ if l = "" then
+ pp f "%a@ " self#simple_pattern p (*single case pattern parens needed here *)
+ else
+ if l.[0] = '?' then
+ let len = String.length l - 1 in
+ let rest = String.sub l 1 len in begin
+ match p.ppat_desc with
+ | Ppat_var {txt;_} when txt = rest ->
+ (match opt with
+ |Some o -> pp f "?(%s=@;%a)@;" rest self#expression o
+ | None -> pp f "?%s@ " rest)
+ | _ -> (match opt with
+ | Some o -> pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o
+ | None -> pp f "%s:%a@;" l self#simple_pattern p )
+ end
+ else
+ (match p.ppat_desc with
+ | Ppat_var {txt;_} when txt = l ->
+ pp f "~%s@;" l
+ | _ -> pp f "~%s:%a@;" l self#simple_pattern p )
+ method sugar_expr f e =
+ match e.pexp_desc with
+ | Pexp_apply
+ ({pexp_desc=
+ Pexp_ident
+ {txt= Ldot (Lident (("Array"|"String") as s),"get");_};_},
+ [(_,e1);(_,e2)]) -> begin
+ let fmt:(_,_,_)format =
+ if s= "Array" then "@[%a.(%a)@]" else "@[%a.[%a]@]" in
+ pp f fmt self#simple_expr e1 self#expression e2;
+ true
+ end
+ |Pexp_apply
+ ({pexp_desc=
+ Pexp_ident
+ {txt= Ldot (Lident (("Array"|"String") as s),
+ "set");_};_},[(_,e1);(_,e2);(_,e3)])
+ ->
+ let fmt :(_,_,_) format=
+ if s= "Array" then
+ "@[%a.(%a)@ <-@;%a@]"
+ else
+ "@[%a.[%a]@ <-@;%a@]" in (* @;< gives error here *)
+ pp f fmt self#simple_expr e1 self#expression e2 self#expression e3;
+ true
+ | Pexp_apply ({pexp_desc=Pexp_ident {txt=Lident "!";_};_}, [(_,e)]) -> begin
+ pp f "@[<hov>!%a@]" self#simple_expr e;
+ true
+ end
+ | Pexp_apply
+ ({pexp_desc=Pexp_ident
+ {txt= Ldot (Ldot (Lident "Bigarray", array), ("get"|"set" as gs)) ;_};_},
+ label_exprs) ->
+ begin match array,gs with
+ | "Genarray","get" ->
+ begin match label_exprs with
+ | [(_,a);(_,{pexp_desc=Pexp_array ls;_})] -> begin
+ pp f "@[%a.{%a}@]" self#simple_expr a
+ (self#list ~sep:"," self#simple_expr ) ls;
+ true
+ end
+ | _ -> false
+ end
+ | "Genarray","set" ->
+ begin match label_exprs with
+ | [(_,a);(_,{pexp_desc=Pexp_array ls;_});(_,c)] -> begin
+ pp f "@[%a.{%a}@ <-@ %a@]" self#simple_expr a
+ (self#list ~sep:"," self#simple_expr ) ls self#simple_expr c;
+ true
+ end
+ | _ -> false
+ end
+ | ("Array1"|"Array2"|"Array3"),"set" ->
+ begin
+ match label_exprs with
+ | (_,a)::rest ->
+ begin match List.rev rest with
+ | (_,v)::rest ->
+ let args = List.map snd (List.rev rest) in
+ pp f "@[%a.{%a}@ <-@ %a@]"
+ self#simple_expr a (self#list ~sep:"," self#simple_expr)
+ args self#simple_expr v;
+ true
+ | _ -> assert false
+ end
+ | _ -> assert false
+ end
+ | ("Array1"|"Array2"|"Array3"),"get" ->
+ begin match label_exprs with
+ |(_,a)::rest ->
+ pp f "@[%a.{%a}@]"
+ self#simple_expr a (self#list ~sep:"," self#simple_expr)
+ (List.map snd rest);
+ true
+ | _ -> assert false
+ end
+ | _ -> false
+ end
+
+ | _ -> false
+ method expression f x =
+ match x.pexp_desc with
+ | Pexp_function _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+ when pipe || semi ->
+ self#paren true self#reset#expression f x
+ | Pexp_ifthenelse _ | Pexp_sequence _ when ifthenelse ->
+ self#paren true self#reset#expression f x
+ | Pexp_let _ | Pexp_letmodule _ when semi ->
+ self#paren true self#reset#expression f x
+ | Pexp_function _(* (p, eo, l) *) ->
+ let rec aux acc = function
+ | {pexp_desc = Pexp_function (l,eo, [(p',e')]);_}
+ -> aux ((l,eo,p')::acc) e'
+ | x -> (List.rev acc,x) in
+ begin match aux [] x with
+ | [], {pexp_desc=Pexp_function(_label,_eo,l);_} -> (* label should be "" *)
+ pp f "@[<hv>function%a@]" self#case_list l
+ | ls, {pexp_desc=Pexp_when(e1,e2);_}->
+ pp f "@[<2>fun@;%a@;when@;%a@;->@;%a@]"
+ (self#list
+ (fun f (l,eo,p) ->
+ self#label_exp f (l,eo,p) )) ls
+ self#reset#expression e1 self#expression e2
+ | ls, e ->
+ pp f "@[<2>fun@;%a@;->@;%a@]"
+ (self#list
+ (fun f (l,eo,p) ->
+ self#label_exp f (l,eo,p))) ls
+ self#expression e end
+ | Pexp_match (e, l) ->
+ pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]" self#reset#expression e self#case_list l
+
+ | Pexp_try (e, l) ->
+ pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]" (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+ self#reset#expression e self#case_list l
+ | Pexp_let (rf, l, e) ->
+ (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" (\*no identation here, a new line*\) *)
+ (* self#rec_flag rf *)
+ pp f "@[<2>%a in@;<1 -2>%a@]"
+ self#reset#bindings (rf,l)
+ self#expression e
+ | Pexp_apply (e, l) ->
+ (if not (self#sugar_expr f x) then
+ match view_fixity_of_exp e with
+ | `Infix s ->
+ (match l with
+ | [ arg1; arg2 ] ->
+ pp f "@[<2>%a@;%s@;%a@]" (* FIXME associativity lable_x_expression_parm*)
+ self#reset#label_x_expression_param arg1 s self#label_x_expression_param arg2
+ | _ ->
+ pp f "@[<2>%a %a@]" self#simple_expr e (self#list self#label_x_expression_param) l)
+ | `Prefix s ->
+ let s =
+ if List.mem s ["~+";"~-";"~+.";"~-."] then String.sub s 1 (String.length s -1)
+ else s in
+ (match l with
+ |[v] -> pp f "@[<2>%s@;%a@]" s self#label_x_expression_param v
+ | _ -> pp f "@[<2>%s@;%a@]" s (self#list self#label_x_expression_param) l (*FIXME assert false*)
+ )
+ | _ ->
+ pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+ pp f "%a@ %a" self#expression2 e
+ (self#list self#reset#label_x_expression_param) l
+ (*reset here only because [function,match,try,sequence] are lower priority*)
+ end (e,l))
+
+ | Pexp_construct (li, Some eo, _)
+ when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+ (match view_expr x with
+ | `cons ls -> self#list self#simple_expr f ls ~sep:"@;::@;"
+ | `normal ->
+ pp f "@[<2>%a@;%a@]" self#longident_loc li
+ self#simple_expr eo
+ | _ -> assert false)
+ | Pexp_setfield (e1, li, e2) ->
+ pp f "@[<2>%a.%a@ <-@ %a@]" self#simple_expr e1 self#longident_loc li self#expression e2;
+ | Pexp_ifthenelse (e1, e2, eo) ->
+ (* @;@[<2>else@ %a@]@] *)
+ let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+ pp f fmt self#under_ifthenelse#expression e1 self#under_ifthenelse#expression e2
+ (fun f eo -> match eo with
+ | Some x -> pp f "@;@[<2>else@;%a@]" self#under_semi#expression x
+ | None -> () (* pp f "()" *)) eo
+ | Pexp_sequence _ ->
+ let rec sequence_helper acc = function
+ | {pexp_desc=Pexp_sequence(e1,e2);_} ->
+ sequence_helper (e1::acc) e2
+ | v -> List.rev (v::acc) in
+ let lst = sequence_helper [] x in
+ pp f "@[<hv>%a@]"
+ (self#list self#under_semi#expression ~sep:";@;") lst
+ | Pexp_when (_e1, _e2) -> assert false (*FIXME handled already in pattern *)
+ | Pexp_new (li) ->
+ pp f "@[<hov2>new@ %a@]" self#longident_loc li;
+ | Pexp_setinstvar (s, e) ->
+ pp f "@[<hov2>%s@ <-@ %a@]" s.txt self#expression e
+ | Pexp_override l -> (* FIXME *)
+ let string_x_expression f (s, e) =
+ pp f "@[<hov2>%s@ =@ %a@]" s.txt self#expression e in
+ pp f "@[<hov2>{<%a>}@]"
+ (self#list string_x_expression ~sep:";" ) l;
+ | Pexp_letmodule (s, me, e) ->
+ pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
+ self#reset#module_expr me self#expression e
+ | Pexp_assert e ->
+ pp f "@[<hov2>assert@ %a@]" self#simple_expr e
+ | Pexp_assertfalse ->
+ pp f "@[<2>assert@;false@]" ;
+ | Pexp_lazy (e) ->
+ pp f "@[<hov2>lazy@ %a@]" self#simple_expr e
+ | Pexp_poly _ ->
+ assert false
+ | Pexp_open (ovf, lid, e) ->
+ pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid
+ self#expression e
+ | Pexp_variant (l,Some eo) ->
+ pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
+ | _ -> self#expression1 f x
+ method expression1 f x =
+ match x.pexp_desc with
+ | Pexp_object cs -> pp f "%a" self#class_structure cs
+ | _ -> self#expression2 f x
+ (* used in [Pexp_apply] *)
+ method expression2 f x =
+ match x.pexp_desc with
+ | Pexp_field (e, li) -> pp f "@[<hov2>%a.%a@]" self#simple_expr e self#longident_loc li
+ | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" self#simple_expr e s
+
+ | _ -> self#simple_expr f x
+ method simple_expr f x =
+ match x.pexp_desc with
+ | Pexp_construct _ when is_simple_construct (view_expr x) ->
+ (match view_expr x with
+ | `nil -> pp f "[]"
+ | `tuple -> pp f "()"
+ | `list xs -> pp f "@[<hv0>[%a]@]" (self#list self#under_semi#expression ~sep:";@;") xs
+ | `simple x -> self#longident f x
+ | _ -> assert false)
+ | Pexp_ident li ->
+ self#longident_loc f li
+ (* (match view_fixity_of_exp x with *)
+ (* |`Normal -> self#longident_loc f li *)
+ (* | `Prefix _ | `Infix _ -> pp f "( %a )" self#longident_loc li) *)
+ | Pexp_constant c -> self#constant f c;
+ | Pexp_pack me ->
+ pp f "(module@;%a)" self#module_expr me
+ | Pexp_newtype (lid, e) ->
+ pp f "fun@;(type@;%s)@;->@;%a" lid self#expression e
+ | Pexp_tuple l ->
+ pp f "@[<hov2>(%a)@]" (self#list self#simple_expr ~sep:",@;") l
+ | Pexp_constraint (e, cto1, cto2) ->
+ pp f "(%a%a%a)" self#expression e
+ (self#option self#core_type ~first:" : " ~last:" ") cto1 (* no sep hint*)
+ (self#option self#core_type ~first:" :>") cto2
+ | Pexp_variant (l, None) -> pp f "`%s" l
+ | Pexp_record (l, eo) ->
+ let longident_x_expression f ( li, e) =
+ match e.pexp_desc with
+ | Pexp_ident {txt;_} when li.txt = txt ->
+ pp f "@[<hov2>%a@]" self#longident_loc li
+ | _ ->
+ pp f "@[<hov2>%a@;=@;%a@]" self#longident_loc li self#simple_expr e in
+ pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
+ (self#option ~last:" with@;" self#simple_expr) eo
+ (self#list longident_x_expression ~sep:";@;") l
+ | Pexp_array (l) ->
+ pp f "@[<0>@[<2>[|%a|]@]@]"
+ (self#list self#under_semi#simple_expr ~sep:";") l
+ | Pexp_while (e1, e2) ->
+ let fmt:(_,_,_)format = "@[<2>while@;%a@;do@;%a@;done@]" in
+ pp f fmt self#expression e1 self#expression e2
+ | Pexp_for (s, e1, e2, df, e3) ->
+ let fmt:(_,_,_)format =
+ "@[<hv0>@[<hv2>@[<2>for %s =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+ pp f fmt s.txt self#expression e1 self#direction_flag df self#expression e2 self#expression e3
+ | _ -> self#paren true self#expression f x
+
+
+ method value_description f x =
+ pp f "@[<hov2>%a%a@]" self#core_type x.pval_type
+ (fun f x ->
+ if x.pval_prim<>[] then begin
+ pp f "@ =@ %a"
+ (self#list self#constant_string)
+ x.pval_prim ;
+ end) x
+
+
+ method exception_declaration f (s,ed) =
+ pp f "@[<hov2>exception@ %s%a@]" s
+ (fun f ed -> match ed with
+ |[] -> ()
+ |_ -> pp f "@ of@ %a" (self#list ~sep:"*" self#core_type) ed) ed
+
+
+ method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} =
+ let class_type_field f x =
+ match x.pctf_desc with
+ | Pctf_inher (ct) ->
+ pp f "@[<2>inherit@ %a@]" self#class_type ct
+ | Pctf_val (s, mf, vf, ct) ->
+ pp f "@[<2>val @ %a%a%s@ :@ %a@]"
+ self#mutable_flag mf self#virtual_flag vf s self#core_type ct
+ | Pctf_virt (s, pf, ct) -> (* todo: test this *)
+ pp f "@[<2>method@ %a@ virtual@ %s@ :@ %a@]"
+ self#private_flag pf s self#core_type ct
+ | Pctf_meth (s, pf, ct) ->
+ pp f "@[<2>method %a%s :@;%a@]"
+ self#private_flag pf s self#core_type ct
+ | Pctf_cstr (ct1, ct2) ->
+ pp f "@[<2>constraint@ %a@ =@ %a@]"
+ self#core_type ct1 self#core_type ct2 in
+ pp f "@[<hv0>@[<hv2>object @[<1>%a@]@ %a@]@ end@]"
+ (fun f ct -> match ct.ptyp_desc with
+ | Ptyp_any -> ()
+ | _ -> pp f "(%a)" self#core_type ct) ct
+ (self#list class_type_field ~sep:"@;") l ;
+
+ (* call [class_signature] called by [class_signature] *)
+ method class_type f x =
+ match x.pcty_desc with
+ | Pcty_signature cs -> self#class_signature f cs;
+ | Pcty_constr (li, l) ->
+ pp f "%a%a"
+ (fun f l -> match l with
+ | [] -> ()
+ | _ -> pp f "[%a]@ " (self#list self#core_type ~sep:"," ) l) l
+ self#longident_loc li
+ | Pcty_fun (l, co, cl) ->
+ pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+ self#type_with_label (l,co) self#class_type cl
+
+
+ (* [class type a = object end] *)
+ method class_type_declaration_list f l =
+ let class_type_declaration f ({pci_params=(ls,_);pci_name={txt;_};pci_variance;_} as x) =
+ pp f "%a%a%s@ =@ %a" self#virtual_flag x.pci_virt
+ self#class_params_def (List.combine ls pci_variance) txt
+ self#class_type x.pci_expr in
+ match l with
+ | [] -> ()
+ | [h] -> pp f "@[<hv2>class type %a@]" class_type_declaration h
+ | _ ->
+ pp f "@[<2>class type %a@]"
+ (self#list class_type_declaration ~sep:"@]@;@[<2>and@;") l
+
+ method class_field f x =
+ match x.pcf_desc with
+ | Pcf_inher (ovf, ce, so) ->
+ pp f "@[<2>inherit@ %s@ %a%a@]" (override ovf) self#class_expr ce
+ (fun f so -> match so with
+ | None -> ();
+ | Some (s) -> pp f "@ as %s" s ) so
+ | Pcf_val (s, mf, ovf, e) ->
+ pp f "@[<2>val%s %a%s =@;%a@]" (override ovf) self#mutable_flag mf
+ s.txt self#expression e
+ | Pcf_virt (s, pf, ct) ->
+ pp f "@[<2>method virtual %a %s :@;%a@]"
+ self#private_flag pf s.txt self#core_type ct
+ | Pcf_valvirt (s, mf, ct) ->
+ pp f "@[<2>val virtual %a%s :@ %a@]"
+ self#mutable_flag mf s.txt
+ self#core_type ct
+ | Pcf_meth (s, pf, ovf, e) ->
+ pp f "@[<2>method%s %a%a@]"
+ (override ovf)
+ self#private_flag pf
+ (fun f e -> match e.pexp_desc with
+ | Pexp_poly (e, Some ct) ->
+ pp f "%s :@;%a=@;%a"
+ s.txt (self#core_type) ct self#expression e
+ | Pexp_poly (e,None) ->
+ self#binding f ({ppat_desc=Ppat_var s;ppat_loc=Location.none} ,e)
+ | _ ->
+ self#expression f e ) e
+ | Pcf_constr (ct1, ct2) ->
+ pp f "@[<2>constraint %a =@;%a@]" self#core_type ct1 self#core_type ct2
+ | Pcf_init (e) ->
+ pp f "@[<2>initializer@ %a@]" self#expression e
+
+ method class_structure f { pcstr_pat = p; pcstr_fields = l } =
+ pp f "@[<hv0>@[<hv2>object %a@;%a@]@;end@]"
+ (fun f p -> match p.ppat_desc with
+ | Ppat_any -> ()
+ | Ppat_constraint _ -> pp f "%a" self#pattern p
+ | _ -> pp f "(%a)" self#pattern p) p
+ (self#list self#class_field ) l
+
+ method class_expr f x =
+ match x.pcl_desc with
+ | Pcl_structure (cs) -> self#class_structure f cs ;
+ | Pcl_fun (l, eo, p, e) ->
+ pp f "fun@ %a@ ->@ %a" self#label_exp (l,eo,p) self#class_expr e
+ | Pcl_let (rf, l, ce) ->
+ (* pp f "let@;%a%a@ in@ %a" *)
+ pp f "%a@ in@ %a"
+ (* self#rec_flag rf *)
+ self#bindings (rf,l)
+ self#class_expr ce
+ | Pcl_apply (ce, l) ->
+ pp f "(%a@ %a)" self#class_expr ce (self#list self#label_x_expression_param) l
+ | Pcl_constr (li, l) ->
+ pp f "%a%a"
+ (fun f l-> if l <>[] then
+ pp f "[%a]@ "
+ (self#list self#core_type ~sep:"," ) l ) l
+ self#longident_loc li
+ | Pcl_constraint (ce, ct) ->
+ pp f "(%a@ :@ %a)"
+ self#class_expr ce
+ self#class_type ct
+
+
+
+ method module_type f x =
+ match x.pmty_desc with
+ | Pmty_ident li ->
+ pp f "%a" self#longident_loc li;
+ | Pmty_signature (s) ->
+ pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+ (self#list self#signature_item ) s (* FIXME wrong indentation*)
+ | Pmty_functor (s, mt1, mt2) ->
+ pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
+ self#module_type mt1 self#module_type mt2
+ | Pmty_with (mt, l) ->
+ let longident_x_with_constraint f (li, wc) =
+ match wc with
+ | Pwith_type ({ptype_params= ls ;_} as td) ->
+ pp f "type@ %a %a =@ %a"
+ (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
+ ls self#longident_loc li self#type_declaration td
+ | Pwith_module (li2) ->
+ pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2;
+ | Pwith_typesubst ({ptype_params=ls;_} as td) ->
+ pp f "type@ %a %a :=@ %a"
+ (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
+ ls self#longident_loc li
+ self#type_declaration td
+ | Pwith_modsubst (li2) ->
+ pp f "module %a :=@ %a" self#longident_loc li self#longident_loc li2 in
+ (match l with
+ | [] -> pp f "@[<hov2>%a@]" self#module_type mt
+ | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
+ self#module_type mt (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
+ | Pmty_typeof me ->
+ pp f "@[<hov2>module@ type@ of@ %a@]"
+ self#module_expr me
+ method signature f x = self#list ~sep:"@\n" self#signature_item f x
+
+ method signature_item f x :unit= begin
+ match x.psig_desc with
+ | Psig_type l ->
+ self#type_def_list f l
+ | Psig_value (s, vd) ->
+ pp f "@[<2>%a@]"
+ (fun f (s,vd) ->
+ let intro = if vd.pval_prim = [] then "val" else "external" in
+ if (is_infix (fixity_of_string s.txt)) || List.mem s.txt.[0] prefix_symbols then
+ pp f "%s@ (@ %s@ )@ :@ " intro s.txt
+ else
+ pp f "%s@ %s@ :@ " intro s.txt;
+ self#value_description f vd;) (s,vd)
+ | Psig_exception (s, ed) ->
+ self#exception_declaration f (s.txt,ed)
+ | Psig_class l ->
+ let class_description f ({pci_params=(ls,_);pci_name={txt;_};pci_variance;_} as x) =
+ pp f "%a%a%s@;:@;%a" (* "@[<2>class %a%a%s@;:@;%a@]" *)
+ self#virtual_flag x.pci_virt
+ self#class_params_def
+ (List.combine ls pci_variance)
+ txt self#class_type x.pci_expr in
+ pp f "@[<0>%a@]"
+ (fun f l -> match l with
+ |[] ->()
+ |[x] -> pp f "@[<2>class %a@]" class_description x
+ |_ -> self#list ~first:"@[<v0>class @[<2>" ~sep:"@]@;and @[" ~last:"@]@]"
+ class_description f l) l
+ | Psig_module (s, mt) ->
+ pp f "@[<hov>module@ %s@ :@ %a@]"
+ s.txt
+ self#module_type mt
+ | Psig_open (ovf, li) ->
+ pp f "@[<hov2>open%s@ %a@]" (override ovf) self#longident_loc li
+ | Psig_include (mt) ->
+ pp f "@[<hov2>include@ %a@]"
+ self#module_type mt
+ | Psig_modtype (s, md) ->
+ pp f "@[<hov2>module@ type@ %s%a@]"
+ s.txt
+ (fun f md -> match md with
+ | Pmodtype_abstract -> ()
+ | Pmodtype_manifest (mt) ->
+ pp_print_space f () ;
+ pp f "@ =@ %a" self#module_type mt
+ ) md
+ | Psig_class_type (l) ->
+ self#class_type_declaration_list f l ;
+ | Psig_recmodule decls ->
+ let rec string_x_module_type_list f ?(first=true) l =
+ match l with
+ | [] -> () ;
+ | (s,mty) :: tl ->
+ if not first then
+ pp f "@ @[<hov2>and@ %s:@ %a@]"
+ s.txt self#module_type mty
+ else
+ pp f "@ @[<hov2>module@ rec@ %s:@ %a@]"
+ s.txt self#module_type mty;
+ string_x_module_type_list f ~first:false tl in
+ string_x_module_type_list f decls
+ end
+ method module_expr f x =
+ match x.pmod_desc with
+ | Pmod_structure (s) ->
+ pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
+ (self#list self#structure_item ~sep:"@\n") s;
+ | Pmod_constraint (me, mt) ->
+ pp f "@[<hov2>(%a@ :@ %a)@]"
+ self#module_expr me
+ self#module_type mt
+ | Pmod_ident (li) ->
+ pp f "%a" self#longident_loc li;
+ | Pmod_functor (s, mt, me) ->
+ pp f "functor@ (%s@ :@ %a)@;->@;%a"
+ s.txt self#module_type mt self#module_expr me
+ | Pmod_apply (me1, me2) ->
+ pp f "%a(%a)" self#module_expr me1 self#module_expr me2
+ | Pmod_unpack e ->
+ pp f "(val@ %a)" self#expression e
+
+ method structure f x = self#list ~sep:"@\n" self#structure_item f x
+
+ (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+ method binding f ((p:pattern),(x:expression)) =
+ let rec pp_print_pexp_function f x =
+ match x.pexp_desc with
+ | Pexp_function (label,eo,[(p,e)]) ->
+ if label="" then
+ match e.pexp_desc with
+ | Pexp_when _ -> pp f "=@;%a" self#expression x
+ | _ ->
+ pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
+ else
+ pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
+ | Pexp_newtype (str,e) ->
+ pp f "(type@ %s)@ %a" str pp_print_pexp_function e
+ | _ -> pp f "=@;%a" self#expression x in
+ match (x.pexp_desc,p.ppat_desc) with
+ | (Pexp_when (e1,e2),_) ->
+ pp f "=@[<2>fun@ %a@ when@ %a@ ->@ %a@]"
+ self#simple_pattern p self#expression e1 self#expression e2
+ | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
+ (match ty.ptyp_desc with
+ | Ptyp_poly _ ->
+ pp f "%a@;:@;%a=@;%a" self#simple_pattern p self#core_type ty self#expression x
+ | _ ->
+ pp f "(%a@;:%a)=@;%a" self#simple_pattern p self#core_type ty self#expression x)
+ | Pexp_constraint (e,Some t1,None),Ppat_var {txt;_} ->
+ pp f "%s:@ %a@;=@;%a" txt self#core_type t1 self#expression e
+ | (_, Ppat_var _) ->
+ pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function x
+ | _ ->
+ pp f "%a@;=@;%a" self#pattern p self#expression x
+ (* [in] is not printed *)
+ method bindings f (rf,l) =
+ begin match l with
+ | [] -> ()
+ | [x] -> pp f "@[<2>let %a%a@]" self#rec_flag rf self#binding x
+ | x::xs ->
+ (* pp f "@[<hv0>let %a@[<2>%a%a@]" *)
+ (* FIXME the indentation is not good see [Insert].ml*)
+ pp f "@[<hv0>@[<2>let %a%a%a@]"
+ self#rec_flag rf self#binding x
+ (fun f l -> match l with
+ | [] -> assert false
+ | [x] ->
+ pp f
+ (* "@]@;and @[<2>%a@]" *)
+ "@]@;@[<2>and %a@]"
+ self#binding x
+ | xs ->
+ self#list self#binding
+ (* ~first:"@]@;and @[<2>" *)
+ ~first:"@]@;@[<2>and "
+ (* ~sep:"@]@;and @[<2>" *)
+ ~sep:"@]@;@[<2>and "
+ ~last:"@]" f xs ) xs
+ end
+
+ method structure_item f x = begin
+ match x.pstr_desc with
+ | Pstr_eval (e) ->
+ pp f "@[<hov2>let@ _ =@ %a@]" self#expression e
+ | Pstr_type [] -> assert false
+ | Pstr_type l -> self#type_def_list f l
+ | Pstr_value (rf, l) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *)
+ pp f "@[<2>%a@]" self#bindings (rf,l)
+ | Pstr_exception (s, ed) -> self#exception_declaration f (s.txt,ed)
+ | Pstr_module (s, me) ->
+ let rec module_helper me = match me.pmod_desc with
+ | Pmod_functor(s,mt,me) ->
+ pp f "(%s:%a)" s.txt self#module_type mt ;
+ module_helper me
+ | _ -> me in
+ pp f "@[<hov2>module %s%a@]"
+ s.txt
+ (fun f me ->
+ let me = module_helper me in
+ (match me.pmod_desc with
+ | Pmod_constraint
+ (me,
+ ({pmty_desc=(Pmty_ident (_)
+ | Pmty_signature (_));_} as mt)) ->
+ pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me
+ | _ ->
+ pp f " =@ %a" self#module_expr me
+ )) me
+ | Pstr_open (ovf, li) ->
+ pp f "@[<2>open%s@;%a@]" (override ovf) self#longident_loc li;
+ | Pstr_modtype (s, mt) ->
+ pp f "@[<2>module type %s =@;%a@]" s.txt self#module_type mt
+ | Pstr_class l ->
+ let class_declaration f (* for the second will be changed to and FIXME*)
+ ({pci_params=(ls,_);
+ pci_name={txt;_};
+ pci_virt;
+ pci_expr={pcl_desc;_};
+ pci_variance;_ } as x) =
+ let ls = List.combine ls pci_variance in
+ let rec class_fun_helper f e = match e.pcl_desc with
+ | Pcl_fun (l, eo, p, e) ->
+ self#label_exp f (l,eo,p);
+ class_fun_helper f e
+ | _ -> e in
+ pp f "%a%a%s %a" self#virtual_flag pci_virt self#class_params_def ls txt
+ (fun f _ ->
+ let ce =
+ (match pcl_desc with
+ | Pcl_fun _ ->
+ class_fun_helper f x.pci_expr;
+ | _ -> x.pci_expr) in
+ let ce =
+ (match ce.pcl_desc with
+ | Pcl_constraint (ce, ct) ->
+ pp f ": @[%a@] " self#class_type ct ;
+ ce
+ | _ -> ce ) in
+ pp f "=@;%a" self#class_expr ce ) x in
+ (match l with
+ | [] -> ()
+ | [x] -> pp f "@[<2>class %a@]" class_declaration x
+ | xs -> self#list
+ ~first:"@[<v0>class @[<2>"
+ ~sep:"@]@;and @["
+ ~last:"@]@]" class_declaration f xs)
+ | Pstr_class_type (l) ->
+ self#class_type_declaration_list f l ;
+ | Pstr_primitive (s, vd) ->
+ let need_parens =
+ match s.txt with
+ | "or" | "mod" | "land"| "lor" | "lxor" | "lsl" | "lsr" | "asr" -> true
+ | _ -> match s.txt.[0] with
+ 'a'..'z' -> false | _ -> true in
+ pp f "@[<hov2>external@ %s@ :@ %a@]"
+ (if need_parens then "( "^s.txt^" )" else s.txt)
+ self#value_description vd
+ | Pstr_include me ->
+ pp f "@[<hov2>include@ %a@]" self#module_expr me
+ | Pstr_exn_rebind (s, li) -> (* todo: check this *)
+ pp f "@[<hov2>exception@ %s@ =@ %a@]" s.txt self#longident_loc li
+ | Pstr_recmodule decls -> (* 3.07 *)
+ let text_x_modtype_x_module f (s, mt, me) =
+ pp f "@[<hov2>and@ %s:%a@ =@ %a@]"
+ s.txt self#module_type mt self#module_expr me
+ in match decls with
+ | (s,mt,me):: l2 ->
+ pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]@ %a@]"
+ s.txt
+ self#module_type mt
+ self#module_expr me
+ (fun f l2 -> List.iter (text_x_modtype_x_module f) l2) l2
+ | _ -> assert false
+ end
+ method type_param f = function
+ | (a,opt) -> pp f "%s%a" (type_variance a ) self#type_var_option opt
+ (* shared by [Pstr_type,Psig_type]*)
+ method type_def_list f l =
+ let aux f (s, ({ptype_params;ptype_kind;ptype_manifest;ptype_variance;_} as td )) =
+ let ptype_params = List.combine ptype_variance ptype_params in
+ pp f "%a%s%a"
+ (fun f l -> match l with
+ |[] -> ()
+ | _ -> pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l)
+ ptype_params s.txt
+ (fun f td ->begin match ptype_kind, ptype_manifest with
+ | Ptype_abstract, None -> ()
+ | _ , _ -> pp f " =@;" end;
+ pp f "%a" self#type_declaration td ) td in
+ match l with
+ | [] -> () ;
+ | [x] -> pp f "@[<2>type %a@]" aux x
+ | xs -> pp f "@[<v>@[<2>type %a"
+ (self#list aux ~sep:"@]@,@[<2>and " ~last:"@]@]") xs
+ (* called by type_def_list *)
+ method type_declaration f x = begin
+ let type_variant_leaf f (s, l,gadt, _loc) = match gadt with
+ |None ->
+ pp f "@\n|@;%s%a" s.txt
+ (fun f l -> match l with
+ | [] -> ()
+ | _ -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l) l
+ |Some x ->
+ pp f "@\n|@;%s:@;%a" s.txt
+ (self#list self#core_type1 ~sep:"@;->@;") (l@[x]) in
+ pp f "%a%a@ %a"
+ (fun f x -> match (x.ptype_manifest,x.ptype_kind,x.ptype_private) with
+ | (None,_,Public) -> pp f "@;"
+ | (None,Ptype_abstract,Private) -> pp f "@;" (* private type without print*)
+ | (None,_,Private) -> pp f "private@;"
+ | (Some y, Ptype_abstract,Private) ->
+ pp f "private@;%a" self#core_type y;
+ | (Some y, _, Private) ->
+ pp f "%a = private@;" self#core_type y
+ | (Some y,Ptype_abstract, Public) -> self#core_type f y;
+ | (Some y, _,Public) -> begin
+ pp f "%a =@;" self#core_type y (* manifest types*)
+ end) x
+ (fun f x -> match x.ptype_kind with
+ (*here only normal variant types allowed here*)
+ | Ptype_variant xs ->
+ pp f "%a"
+ (self#list ~sep:"" type_variant_leaf) xs
+ | Ptype_abstract -> ()
+ | Ptype_record l ->
+ let type_record_field f (s, mf, ct,_) =
+ pp f "@[<2>%a%s:@;%a@]" self#mutable_flag mf s.txt self#core_type ct in
+ pp f "{@\n%a}"
+ (self#list type_record_field ~sep:";@\n" ) l ;
+ ) x
+ (self#list
+ (fun f (ct1,ct2,_) ->
+ pp f "@[<hov2>constraint@ %a@ =@ %a@]"
+ self#core_type ct1 self#core_type ct2 )) x.ptype_cstrs ;
+ end
+ method case_list f (l:(pattern * expression) list) :unit=
+ let aux f (p,e) =
+ let (e,w) =
+ (match e with
+ | {pexp_desc = Pexp_when (e1, e2);_} -> (e2, Some (e1))
+ | _ -> (e, None)) in
+ pp f "@;| @[<2>%a%a@;->@;%a@]"
+ self#pattern p (self#option self#expression ~first:"@;when@;") w self#under_pipe#expression e in
+ self#list aux f l ~sep:""
+ method label_x_expression_param f (l,e) =
+ match l with
+ | "" -> self#expression2 f e ; (* level 2*)
+ | lbl ->
+ let simple_name = match e.pexp_desc with
+ | Pexp_ident {txt=Lident l;_} -> Some l
+ | _ -> None in
+ if lbl.[0] = '?' then
+ let str = String.sub lbl 1 (String.length lbl-1) in
+ if Some str = simple_name then
+ pp f "%s" lbl
+ else
+ pp f "%s:%a" lbl self#simple_expr e
+ else
+ if Some lbl = simple_name then
+ pp f "~%s" lbl
+ else
+ pp f "~%s:%a" lbl self#simple_expr e
+
+ method directive_argument f x =
+ (match x with
+ | Pdir_none -> ()
+ | Pdir_string (s) -> pp f "@ %S" s
+ | Pdir_int (i) -> pp f "@ %d" i
+ | Pdir_ident (li) -> pp f "@ %a" self#longident li
+ | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
+
+ method toplevel_phrase f x =
+ match x with
+ | Ptop_def (s) ->
+ pp_open_hvbox f 0;
+ self#list self#structure_item f s ;
+ pp_close_box f ();
+ | Ptop_dir (s, da) ->
+ pp f "@[<hov2>#%s@ %a@]" s self#directive_argument da
+end;;
+
+
+let default = new printer ()
+
+
+let toplevel_phrase f x =
+ match x with
+ | Ptop_def (s) ->pp f "@[<hov0>%a@]" (default#list default#structure_item) s
+ (* pp_open_hvbox f 0; *)
+ (* pp_print_list structure_item f s ; *)
+ (* pp_close_box f (); *)
+ | Ptop_dir (s, da) ->
+ pp f "@[<hov2>#%s@ %a@]" s default#directive_argument da
+ (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)
+
+let expression f x =
+ pp f "@[%a@]" default#expression x
+
+
+let string_of_expression x =
+ ignore (flush_str_formatter ()) ;
+ let f = str_formatter in
+ default#expression f x ;
+ flush_str_formatter () ;;
+let string_of_structure x =
+ ignore (flush_str_formatter ());
+ let f = str_formatter in
+ default#structure f x;
+ flush_str_formatter ();;
+
+let top_phrase f x =
+ pp_print_newline f () ;
+ toplevel_phrase f x;
+ pp f ";;" ;
+ pp_print_newline f ();;
+
+let core_type=default#core_type
+let pattern=default#pattern
+let signature=default#signature
+let structure=default#structure
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Hongbo Zhang (University of Pennsylvania) *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+type space_formatter = (unit, Format.formatter, unit) format
+class printer :
+ unit ->
+ object ('b)
+ val pipe : bool
+ val semi : bool
+ method binding :
+ Format.formatter -> Parsetree.pattern * Parsetree.expression -> unit
+ method bindings:
+ Format.formatter ->
+ Asttypes.rec_flag * (Parsetree.pattern * Parsetree.expression) list ->
+ unit
+ method case_list :
+ Format.formatter ->
+ (Parsetree.pattern * Parsetree.expression) list -> unit
+ method class_expr : Format.formatter -> Parsetree.class_expr -> unit
+ method class_field : Format.formatter -> Parsetree.class_field -> unit
+ method class_params_def :
+ Format.formatter -> (string Asttypes.loc * (bool * bool)) list -> unit
+ method class_signature :
+ Format.formatter -> Parsetree.class_signature -> unit
+ method class_structure :
+ Format.formatter -> Parsetree.class_structure -> unit
+ method class_type : Format.formatter -> Parsetree.class_type -> unit
+ method class_type_declaration_list :
+ Format.formatter -> Parsetree.class_type_declaration list -> unit
+ method constant : Format.formatter -> Asttypes.constant -> unit
+ method constant_string : Format.formatter -> string -> unit
+ method core_type : Format.formatter -> Parsetree.core_type -> unit
+ method core_type1 : Format.formatter -> Parsetree.core_type -> unit
+ method direction_flag :
+ Format.formatter -> Asttypes.direction_flag -> unit
+ method directive_argument :
+ Format.formatter -> Parsetree.directive_argument -> unit
+ method exception_declaration :
+ Format.formatter -> string * Parsetree.exception_declaration -> unit
+ method expression : Format.formatter -> Parsetree.expression -> unit
+ method expression1 : Format.formatter -> Parsetree.expression -> unit
+ method expression2 : Format.formatter -> Parsetree.expression -> unit
+ method label_exp :
+ Format.formatter ->
+ Asttypes.label * Parsetree.expression option * Parsetree.pattern ->
+ unit
+ method label_x_expression_param :
+ Format.formatter -> Asttypes.label * Parsetree.expression -> unit
+ method list :
+ ?sep:space_formatter ->
+ ?first:space_formatter ->
+ ?last:space_formatter ->
+ (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
+ method longident : Format.formatter -> Longident.t -> unit
+ method longident_loc :
+ Format.formatter -> Longident.t Asttypes.loc -> unit
+ method module_expr : Format.formatter -> Parsetree.module_expr -> unit
+ method module_type : Format.formatter -> Parsetree.module_type -> unit
+ method mutable_flag : Format.formatter -> Asttypes.mutable_flag -> unit
+ method option :
+ ?first:space_formatter ->
+ ?last:space_formatter ->
+ (Format.formatter -> 'a -> unit) ->
+ Format.formatter -> 'a option -> unit
+ method paren :
+ ?first:space_formatter -> ?last:space_formatter -> bool ->
+ (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+ method pattern : Format.formatter -> Parsetree.pattern -> unit
+ method pattern1 : Format.formatter -> Parsetree.pattern -> unit
+ method private_flag : Format.formatter -> Asttypes.private_flag -> unit
+ method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
+
+ method reset : 'b
+ method reset_semi : 'b
+ method reset_ifthenelse : 'b
+ method reset_pipe : 'b
+
+ method signature :
+ Format.formatter -> Parsetree.signature_item list -> unit
+ method signature_item :
+ Format.formatter -> Parsetree.signature_item -> unit
+ method simple_expr : Format.formatter -> Parsetree.expression -> unit
+ method simple_pattern : Format.formatter -> Parsetree.pattern -> unit
+ method string_quot : Format.formatter -> Asttypes.label -> unit
+ method structure :
+ Format.formatter -> Parsetree.structure_item list -> unit
+ method structure_item :
+ Format.formatter -> Parsetree.structure_item -> unit
+ method sugar_expr : Format.formatter -> Parsetree.expression -> bool
+ method toplevel_phrase :
+ Format.formatter -> Parsetree.toplevel_phrase -> unit
+ method type_declaration :
+ Format.formatter -> Parsetree.type_declaration -> unit
+ method type_def_list :
+ Format.formatter ->
+ (string Asttypes.loc * Parsetree.type_declaration) list -> unit
+ method type_param :
+ Format.formatter -> (bool * bool) * string Asttypes.loc option -> unit
+ method type_var_option :
+ Format.formatter -> string Asttypes.loc option -> unit
+ method type_with_label :
+ Format.formatter -> Asttypes.label * Parsetree.core_type -> unit
+ method tyvar : Format.formatter -> string -> unit
+ method under_pipe : 'b
+ method under_semi : 'b
+ method under_ifthenelse : 'b
+ method value_description :
+ Format.formatter -> Parsetree.value_description -> unit
+ method virtual_flag : Format.formatter -> Asttypes.virtual_flag -> unit
+ end
+val default : printer
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
(* *)
(***********************************************************************)
-(* $Id: printast.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Asttypes;;
open Format;;
open Lexing;;
open Location;;
open Parsetree;;
-let fmt_position f l =
+let fmt_position with_name f l =
+ let fname = if with_name then l.pos_fname else "" in
if l.pos_lnum = -1
- then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
- else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+ then fprintf f "%s[%d]" fname l.pos_cnum
+ else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
(l.pos_cnum - l.pos_bol)
;;
let fmt_location f loc =
- fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+ let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+ fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+ (fmt_position p_2nd_name) loc.loc_end;
if loc.loc_ghost then fprintf f " ghost";
;;
fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
;;
-let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;;
-let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f x =
+ fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f x =
+ fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
let fmt_constant f x =
match x with
;;
let line i f s (*...*) =
- fprintf f "%s" (String.make (2*i) ' ');
+ fprintf f "%s" (String.make ((2*i) mod 72) ' ');
fprintf f s (*...*)
;;
f (i+1) ppf x;
;;
-let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
let string i ppf s = line i ppf "\"%s\"\n" s;;
-let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
let bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
let label i ppf x = line i ppf "label=\"%s\"\n" x;;
line i ppf "Ptyp_tuple\n";
list i core_type ppf l;
| Ptyp_constr (li, l) ->
- line i ppf "Ptyp_constr %a\n" fmt_longident li;
+ line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
list i core_type ppf l;
| Ptyp_variant (l, closed, low) ->
line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed);
line i ppf "Ptyp_object\n";
list i core_field_type ppf l;
| Ptyp_class (li, l, low) ->
- line i ppf "Ptyp_class %a\n" fmt_longident li;
+ line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
list i core_type ppf l;
list i string ppf low
| Ptyp_alias (ct, s) ->
(fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
core_type i ppf ct;
| Ptyp_package (s, l) ->
- line i ppf "Ptyp_package %a\n" fmt_longident s;
+ line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
list i package_with ppf l;
and package_with i ppf (s, t) =
- line i ppf "with type %a\n" fmt_longident s;
+ line i ppf "with type %a\n" fmt_longident_loc s;
core_type i ppf t
and core_field_type i ppf x =
let i = i+1 in
match x.ppat_desc with
| Ppat_any -> line i ppf "Ppat_any\n";
- | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s.txt;
+ | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
| Ppat_alias (p, s) ->
- line i ppf "Ppat_alias \"%s\"\n" s.txt;
+ line i ppf "Ppat_alias %a\n" fmt_string_loc s;
pattern i ppf p;
| Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
| Ppat_tuple (l) ->
line i ppf "Ppat_tuple\n";
list i pattern ppf l;
| Ppat_construct (li, po, b) ->
- line i ppf "Ppat_construct %a\n" fmt_longident li;
+ line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
option i pattern ppf po;
bool i ppf b;
| Ppat_variant (l, po) ->
line i ppf "Ppat_lazy\n";
pattern i ppf p;
| Ppat_constraint (p, ct) ->
- line i ppf "Ppat_constraint";
+ line i ppf "Ppat_constraint\n";
pattern i ppf p;
core_type i ppf ct;
| Ppat_type (li) ->
- line i ppf "Ppat_type";
- longident i ppf li
+ line i ppf "Ppat_type\n";
+ longident_loc i ppf li
| Ppat_unpack s ->
- line i ppf "Ppat_unpack \"%s\"\n" s.txt;
+ line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
and expression i ppf x =
line i ppf "expression %a\n" fmt_location x.pexp_loc;
let i = i+1 in
match x.pexp_desc with
- | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident li;
+ | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
| Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
| Pexp_let (rf, l, e) ->
line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
line i ppf "Pexp_tuple\n";
list i expression ppf l;
| Pexp_construct (li, eo, b) ->
- line i ppf "Pexp_construct %a\n" fmt_longident li;
+ line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
option i expression ppf eo;
bool i ppf b;
| Pexp_variant (l, eo) ->
| Pexp_field (e, li) ->
line i ppf "Pexp_field\n";
expression i ppf e;
- longident i ppf li;
+ longident_loc i ppf li;
| Pexp_setfield (e1, li, e2) ->
line i ppf "Pexp_setfield\n";
expression i ppf e1;
- longident i ppf li;
+ longident_loc i ppf li;
expression i ppf e2;
| Pexp_array (l) ->
line i ppf "Pexp_array\n";
expression i ppf e1;
expression i ppf e2;
| Pexp_for (s, e1, e2, df, e3) ->
- line i ppf "Pexp_for \"%s\" %a\n" s.txt fmt_direction_flag df;
+ line i ppf "Pexp_for %a %a\n" fmt_direction_flag df fmt_string_loc s;
expression i ppf e1;
expression i ppf e2;
expression i ppf e3;
| Pexp_send (e, s) ->
line i ppf "Pexp_send \"%s\"\n" s;
expression i ppf e;
- | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li;
+ | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
| Pexp_setinstvar (s, e) ->
- line i ppf "Pexp_setinstvar \"%s\"\n" s.txt;
+ line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
expression i ppf e;
| Pexp_override (l) ->
line i ppf "Pexp_override\n";
list i string_x_expression ppf l;
| Pexp_letmodule (s, me, e) ->
- line i ppf "Pexp_letmodule \"%s\"\n" s.txt;
+ line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
module_expr i ppf me;
expression i ppf e;
| Pexp_assert (e) ->
- line i ppf "Pexp_assert";
+ line i ppf "Pexp_assert\n";
expression i ppf e;
| Pexp_assertfalse ->
- line i ppf "Pexp_assertfalse";
+ line i ppf "Pexp_assertfalse\n";
| Pexp_lazy (e) ->
- line i ppf "Pexp_lazy";
+ line i ppf "Pexp_lazy\n";
expression i ppf e;
| Pexp_poly (e, cto) ->
line i ppf "Pexp_poly\n";
expression i ppf e;
option i core_type ppf cto;
| Pexp_object s ->
- line i ppf "Pexp_object";
+ line i ppf "Pexp_object\n";
class_structure i ppf s
| Pexp_newtype (s, e) ->
line i ppf "Pexp_newtype \"%s\"\n" s;
expression i ppf e
| Pexp_pack me ->
- line i ppf "Pexp_pack";
+ line i ppf "Pexp_pack\n";
module_expr i ppf me
- | Pexp_open (m, e) ->
- line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
+ | Pexp_open (ovf, m, e) ->
+ line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf
+ fmt_longident_loc m;
expression i ppf e
and value_description i ppf x =
- line i ppf "value_description\n";
+ line i ppf "value_description %a\n" fmt_location x.pval_loc;
core_type (i+1) ppf x.pval_type;
list (i+1) string ppf x.pval_prim;
and string_option_underscore i ppf =
function
| Some x ->
- string i ppf x.txt
+ string_loc i ppf x
| None ->
string i ppf "_"
let i = i+1 in
match x.pcty_desc with
| Pcty_constr (li, l) ->
- line i ppf "Pcty_constr %a\n" fmt_longident li;
+ line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
list i core_type ppf l;
| Pcty_signature (cs) ->
line i ppf "Pcty_signature\n";
core_type i ppf co;
class_type i ppf cl;
-and class_signature i ppf { pcsig_self = ct; pcsig_fields = l } =
- line i ppf "class_signature\n";
- core_type (i+1) ppf ct;
- list (i+1) class_type_field ppf l;
+and class_signature i ppf cs =
+ line i ppf "class_signature %a\n" fmt_location cs.pcsig_loc;
+ core_type (i+1) ppf cs.pcsig_self;
+ list (i+1) class_type_field ppf cs.pcsig_fields;
and class_type_field i ppf x =
- let loc = x.pctf_loc in
+ line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+ let i = i+1 in
match x.pctf_desc with
| Pctf_inher (ct) ->
line i ppf "Pctf_inher\n";
class_type i ppf ct;
| Pctf_val (s, mf, vf, ct) ->
- line i ppf
- "Pctf_val \"%s\" %a %a %a\n" s
- fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
+ line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+ fmt_virtual_flag vf;
core_type (i+1) ppf ct;
| Pctf_virt (s, pf, ct) ->
- line i ppf
- "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+ line i ppf "Pctf_virt \"%s\" %a\n" s fmt_private_flag pf;
core_type (i+1) ppf ct;
| Pctf_meth (s, pf, ct) ->
- line i ppf
- "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+ line i ppf "Pctf_meth \"%s\" %a\n" s fmt_private_flag pf;
core_type (i+1) ppf ct;
| Pctf_cstr (ct1, ct2) ->
- line i ppf "Pctf_cstr %a\n" fmt_location loc;
- core_type i ppf ct1;
- core_type i ppf ct2;
+ line i ppf "Pctf_cstr\n";
+ core_type (i+1) ppf ct1;
+ core_type (i+1) ppf ct2;
and class_description i ppf x =
line i ppf "class_description %a\n" fmt_location x.pci_loc;
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
line i ppf "pci_params =\n";
string_list_x_location (i+1) ppf x.pci_params;
- line i ppf "pci_name = \"%s\"\n" x.pci_name.txt;
+ line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
line i ppf "pci_expr =\n";
class_type (i+1) ppf x.pci_expr;
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
line i ppf "pci_params =\n";
string_list_x_location (i+1) ppf x.pci_params;
- line i ppf "pci_name = \"%s\"\n" x.pci_name.txt;
+ line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
line i ppf "pci_expr =\n";
class_type (i+1) ppf x.pci_expr;
let i = i+1 in
match x.pcl_desc with
| Pcl_constr (li, l) ->
- line i ppf "Pcl_constr %a\n" fmt_longident li;
+ line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
list i core_type ppf l;
| Pcl_structure (cs) ->
line i ppf "Pcl_structure\n";
list (i+1) class_field ppf l;
and class_field i ppf x =
- let loc = x.pcf_loc in
+ line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+ let i = i + 1 in
match x.pcf_desc with
| Pcf_inher (ovf, ce, so) ->
line i ppf "Pcf_inher %a\n" fmt_override_flag ovf;
class_expr (i+1) ppf ce;
option (i+1) string ppf so;
| Pcf_valvirt (s, mf, ct) ->
- line i ppf "Pcf_valvirt \"%s\" %a %a\n"
- s.txt fmt_mutable_flag mf fmt_location loc;
+ line i ppf "Pcf_valvirt %a\n" fmt_mutable_flag mf;
+ line (i+1) ppf "%a\n" fmt_string_loc s;
core_type (i+1) ppf ct;
| Pcf_val (s, mf, ovf, e) ->
- line i ppf "Pcf_val \"%s\" %a %a %a\n"
- s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc;
+ line i ppf "Pcf_val %a %a\n" fmt_mutable_flag mf fmt_override_flag ovf;
+ line (i+1) ppf "%a\n" fmt_string_loc s;
expression (i+1) ppf e;
| Pcf_virt (s, pf, ct) ->
- line i ppf "Pcf_virt \"%s\" %a %a\n"
- s.txt fmt_private_flag pf fmt_location loc;
+ line i ppf "Pcf_virt %a\n" fmt_private_flag pf;
+ line (i+1) ppf "%a\n" fmt_string_loc s;
core_type (i+1) ppf ct;
| Pcf_meth (s, pf, ovf, e) ->
- line i ppf "Pcf_meth \"%s\" %a %a %a\n"
- s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc;
+ line i ppf "Pcf_meth %a %a\n" fmt_private_flag pf fmt_override_flag ovf;
+ line (i+1) ppf "%a\n" fmt_string_loc s;
expression (i+1) ppf e;
| Pcf_constr (ct1, ct2) ->
- line i ppf "Pcf_constr %a\n" fmt_location loc;
+ line i ppf "Pcf_constr\n";
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
| Pcf_init (e) ->
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
line i ppf "pci_params =\n";
string_list_x_location (i+1) ppf x.pci_params;
- line i ppf "pci_name = \"%s\"\n" x.pci_name.txt;
+ line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
line i ppf "pci_expr =\n";
class_expr (i+1) ppf x.pci_expr;
line i ppf "module_type %a\n" fmt_location x.pmty_loc;
let i = i+1 in
match x.pmty_desc with
- | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident li;
+ | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
| Pmty_signature (s) ->
line i ppf "Pmty_signature\n";
signature i ppf s;
| Pmty_functor (s, mt1, mt2) ->
- line i ppf "Pmty_functor \"%s\"\n" s.txt;
+ line i ppf "Pmty_functor %a\n" fmt_string_loc s;
module_type i ppf mt1;
module_type i ppf mt2;
| Pmty_with (mt, l) ->
let i = i+1 in
match x.psig_desc with
| Psig_value (s, vd) ->
- line i ppf "Psig_value \"%s\"\n" s.txt;
+ line i ppf "Psig_value %a\n" fmt_string_loc s;
value_description i ppf vd;
| Psig_type (l) ->
line i ppf "Psig_type\n";
list i string_x_type_declaration ppf l;
| Psig_exception (s, ed) ->
- line i ppf "Psig_exception \"%s\"\n" s.txt;
+ line i ppf "Psig_exception %a\n" fmt_string_loc s;
exception_declaration i ppf ed;
| Psig_module (s, mt) ->
- line i ppf "Psig_module \"%s\"\n" s.txt;
+ line i ppf "Psig_module %a\n" fmt_string_loc s;
module_type i ppf mt;
| Psig_recmodule decls ->
line i ppf "Psig_recmodule\n";
list i string_x_module_type ppf decls;
| Psig_modtype (s, md) ->
- line i ppf "Psig_modtype \"%s\"\n" s.txt;
+ line i ppf "Psig_modtype %a\n" fmt_string_loc s;
modtype_declaration i ppf md;
- | Psig_open li -> line i ppf "Psig_open %a\n" fmt_longident li;
+ | Psig_open (ovf, li) ->
+ line i ppf "Psig_open %a %a\n"
+ fmt_override_flag ovf
+ fmt_longident_loc li;
| Psig_include (mt) ->
line i ppf "Psig_include\n";
module_type i ppf mt;
| Pwith_typesubst (td) ->
line i ppf "Pwith_typesubst\n";
type_declaration (i+1) ppf td;
- | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident li;
- | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
+ | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident_loc li;
+ | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident_loc li;
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
let i = i+1 in
match x.pmod_desc with
- | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident li;
+ | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
| Pmod_structure (s) ->
line i ppf "Pmod_structure\n";
structure i ppf s;
| Pmod_functor (s, mt, me) ->
- line i ppf "Pmod_functor \"%s\"\n" s.txt;
+ line i ppf "Pmod_functor %a\n" fmt_string_loc s;
module_type i ppf mt;
module_expr i ppf me;
| Pmod_apply (me1, me2) ->
line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
list i pattern_x_expression_def ppf l;
| Pstr_primitive (s, vd) ->
- line i ppf "Pstr_primitive \"%s\"\n" s.txt;
+ line i ppf "Pstr_primitive %a\n" fmt_string_loc s;
value_description i ppf vd;
| Pstr_type l ->
line i ppf "Pstr_type\n";
list i string_x_type_declaration ppf l;
| Pstr_exception (s, ed) ->
- line i ppf "Pstr_exception \"%s\"\n" s.txt;
+ line i ppf "Pstr_exception %a\n" fmt_string_loc s;
exception_declaration i ppf ed;
| Pstr_exn_rebind (s, li) ->
- line i ppf "Pstr_exn_rebind \"%s\" %a\n" s.txt fmt_longident li;
+ line i ppf "Pstr_exn_rebind\n";
+ line (i+1) ppf "%a\n" fmt_string_loc s;
+ line (i+1) ppf "%a\n" fmt_longident_loc li;
| Pstr_module (s, me) ->
- line i ppf "Pstr_module \"%s\"\n" s.txt;
+ line i ppf "Pstr_module %a\n" fmt_string_loc s;
module_expr i ppf me;
| Pstr_recmodule bindings ->
line i ppf "Pstr_recmodule\n";
list i string_x_modtype_x_module ppf bindings;
| Pstr_modtype (s, mt) ->
- line i ppf "Pstr_modtype \"%s\"\n" s.txt;
+ line i ppf "Pstr_modtype %a\n" fmt_string_loc s;
module_type i ppf mt;
- | Pstr_open li -> line i ppf "Pstr_open %a\n" fmt_longident li;
+ | Pstr_open (ovf, li) ->
+ line i ppf "Pstr_open %a %a\n"
+ fmt_override_flag ovf
+ fmt_longident_loc li;
| Pstr_class (l) ->
line i ppf "Pstr_class\n";
list i class_declaration ppf l;
module_expr i ppf me
and string_x_type_declaration i ppf (s, td) =
- string i ppf s.txt;
+ string_loc i ppf s;
type_declaration (i+1) ppf td;
and string_x_module_type i ppf (s, mty) =
- string i ppf s.txt;
+ string_loc i ppf s;
module_type (i+1) ppf mty;
and string_x_modtype_x_module i ppf (s, mty, modl) =
- string i ppf s.txt;
+ string_loc i ppf s;
module_type (i+1) ppf mty;
module_expr (i+1) ppf modl;
and longident_x_with_constraint i ppf (li, wc) =
- line i ppf "%a\n" fmt_longident li;
+ line i ppf "%a\n" fmt_longident_loc li;
with_constraint (i+1) ppf wc;
and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
core_type (i+1) ppf ct2;
and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) =
- line i ppf "\"%s\" %a\n" s.txt fmt_location loc;
+ line i ppf "%a\n" fmt_location loc;
+ line (i+1) ppf "%a\n" fmt_string_loc s;
list (i+1) core_type ppf l;
option (i+1) core_type ppf r_opt;
and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
- line i ppf "\"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc;
+ line i ppf "%a\n" fmt_location loc;
+ line (i+1) ppf "%a\n" fmt_mutable_flag mf;
+ line (i+1) ppf "%a" fmt_string_loc s;
core_type (i+1) ppf ct;
and string_list_x_location i ppf (l, loc) =
list (i+1) string_loc ppf l;
and longident_x_pattern i ppf (li, p) =
- line i ppf "%a\n" fmt_longident li;
+ line i ppf "%a\n" fmt_longident_loc li;
pattern (i+1) ppf p;
and pattern_x_expression_case i ppf (p, e) =
expression (i+1) ppf e;
and string_x_expression i ppf (s, e) =
- line i ppf "<override> \"%s\"\n" s.txt;
+ line i ppf "<override> %a\n" fmt_string_loc s;
expression (i+1) ppf e;
and longident_x_expression i ppf (li, e) =
- line i ppf "%a\n" fmt_longident li;
+ line i ppf "%a\n" fmt_longident_loc li;
expression (i+1) ppf e;
and label_x_expression i ppf (l,e) =
| Pdir_none -> line i ppf "Pdir_none\n"
| Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
| Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
- | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident_noloc li;
+ | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
| Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
;;
(* *)
(***********************************************************************)
-(* $Id: printast.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Parsetree;;
open Format;;
(* *)
(***********************************************************************)
-(* $Id: syntaxerr.ml 12256 2012-03-23 02:16:44Z garrigue $ *)
-
(* Auxiliary type for reporting syntax errors *)
open Format
type error =
Unclosed of Location.t * string * Location.t * string
+ | Expecting of Location.t * string
| Applicative_path of Location.t
| Variable_in_scope of Location.t * string
| Other of Location.t
+
exception Error of error
exception Escape_error
fprintf ppf "%aThis '%s' might be unmatched"
Location.print_error opening_loc opening
end
+ | Expecting (loc, nonterm) ->
+ fprintf ppf
+ "%a@[Syntax error: %s expected.@]"
+ Location.print_error loc nonterm
| Applicative_path loc ->
fprintf ppf
"%aSyntax error: applicative paths of the form F(X).t \
Location.print_error loc var var
| Other loc ->
fprintf ppf "%aSyntax error" Location.print_error loc
+
+
+let location_of_error = function
+ | Unclosed(l,_,_,_)
+ | Applicative_path l
+ | Variable_in_scope(l,_)
+ | Other l
+ | Expecting (l, _) -> l
(* *)
(***********************************************************************)
-(* $Id: syntaxerr.mli 12256 2012-03-23 02:16:44Z garrigue $ *)
-
(* Auxiliary type for reporting syntax errors *)
open Format
type error =
Unclosed of Location.t * string * Location.t * string
+ | Expecting of Location.t * string
| Applicative_path of Location.t
| Variable_in_scope of Location.t * string
| Other of Location.t
exception Escape_error
val report_error: formatter -> error -> unit
+
+val location_of_error: error -> Location.t
pervasives.cmx : pervasives.cmi
printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi
-printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
- array.cmi printf.cmi
-printf.cmx : string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \
- array.cmx printf.cmi
+printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \
+ printf.cmi
+printf.cmx : string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \
+ printf.cmi
queue.cmo : obj.cmi queue.cmi
queue.cmx : obj.cmx queue.cmi
random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
pervasives.p.cmx : pervasives.cmi
printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi
-printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
- array.cmi printf.cmi
-printf.p.cmx : string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \
- array.p.cmx printf.cmi
+printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \
+ printf.cmi
+printf.p.cmx : string.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx array.p.cmx \
+ printf.cmi
queue.cmo : obj.cmi queue.cmi
queue.p.cmx : obj.p.cmx queue.cmi
random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
# #
#########################################################################
-# $Id: Compflags 11240 2011-10-25 12:09:01Z weis $
-
case $1 in
pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
camlinternalOO.cmi) echo ' -nopervasives';;
camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+ buffer.cmx|buffer.p.cmx) echo ' -inline 3';;
+ # make sure add_char is inlined (PR#5872)
buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';;
scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
include Makefile.shared
allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING)
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
include Makefile.shared
allopt: stdlib.cmxa std_exit.cmx
# #
#########################################################################
-# $Id: Makefile.shared 12383 2012-04-19 13:12:23Z xleroy $
-
include ../config/Makefile
RUNTIME=../boot/ocamlrun
COMPILER=../ocamlc
CAMLC=$(RUNTIME) $(COMPILER)
-COMPFLAGS=-strict-sequence -g -warn-error A -nostdlib
+COMPFLAGS=-strict-sequence -w +33..39 -g -warn-error A -nostdlib
OPTCOMPILER=../ocamlopt
CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
OPTCOMPFLAGS=-warn-error A -nostdlib -g
# #
#########################################################################
-# $Id: StdlibModules 11156 2011-07-27 14:17:02Z doligez $
-
# This file lists all standard library modules.
# It is used in particular to know what to expunge in toplevels.
(* *)
(***********************************************************************)
-(* $Id: arg.ml 11946 2011-12-23 13:34:13Z protzenk $ *)
-
type key = string
type doc = string
type usage_msg = string
let print_spec buf (key, spec, doc) =
if String.length doc > 0 then
match spec with
- | Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l)
- doc
- | _ -> bprintf buf " %s %s\n" key doc
+ | Symbol (l, _) ->
+ bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) doc
+ | _ ->
+ bprintf buf " %s %s\n" key doc
;;
let help_action () = raise (Stop (Unknown "-help"));;
let current = ref 0;;
-let parse_argv ?(current=current) argv speclist anonfun errmsg =
+let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
let l = Array.length argv in
let b = Buffer.create 200 in
let initpos = !current in
| Message s ->
bprintf b "%s: %s.\n" progname s
end;
- usage_b b speclist errmsg;
+ usage_b b !speclist errmsg;
if error = Unknown "-help" || error = Unknown "--help"
then raise (Help (Buffer.contents b))
else raise (Bad (Buffer.contents b))
let s = argv.(!current) in
if String.length s >= 1 && String.get s 0 = '-' then begin
let action =
- try assoc3 s speclist
+ try assoc3 s !speclist
with Not_found -> stop (Unknown s)
in
begin try
done;
;;
+let parse_argv ?(current=current) argv speclist anonfun errmsg =
+ parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg;
+;;
+
let parse l f msg =
try
parse_argv Sys.argv l f msg;
| Help msg -> printf "%s" msg; exit 0;
;;
-let rec second_word s =
+let parse_dynamic l f msg =
+ try
+ parse_argv_dynamic Sys.argv l f msg;
+ with
+ | Bad msg -> eprintf "%s" msg; exit 2;
+ | Help msg -> printf "%s" msg; exit 0;
+;;
+
+let second_word s =
let len = String.length s in
let rec loop n =
if n >= len then len
(* *)
(***********************************************************************)
-(* $Id: arg.mli 11939 2011-12-22 14:04:18Z protzenk $ *)
-
(** Parsing of command line arguments.
This module provides a general mechanism for extracting options and
by specifying your own [-help] and [--help] options in [speclist].
*)
+val parse_dynamic :
+ (string * spec * string) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse}, except that the [speclist] argument is a reference
+ and may be updated during the parsing. A typical use for this feature
+ is to parse command lines of the form:
+- command subcommand [options]
+ where the list of options depends on the value of the subcommand argument.
+*)
+
val parse_argv : ?current: int ref -> string array ->
(key * spec * doc) list -> anon_fun -> usage_msg -> unit
(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses
as argument.
*)
+val parse_argv_dynamic : ?current:int ref -> string array ->
+ (string * spec * string) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv}, except that the [speclist] argument is a
+ reference and may be updated during the parsing.
+ See {!Arg.parse_dynamic}.
+*)
+
exception Help of string
(** Raised by [Arg.parse_argv] when the user asks for help. *)
(* *)
(***********************************************************************)
-(* $Id: array.ml 12891 2012-08-28 15:07:45Z xleroy $ *)
-
(* Array operations *)
external length : 'a array -> int = "%array_length"
external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
external concat : 'a array list -> 'a array = "caml_array_concat"
-external unsafe_blit : 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
+external unsafe_blit :
+ 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
let init l f =
if l = 0 then [||] else
set a i e;
end;
in
- let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in
+ let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
let rec bubbledown l i =
let j = maxson l i in
set a i (get a j);
(* *)
(***********************************************************************)
-(* $Id: array.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Array operations. *)
external length : 'a array -> int = "%array_length"
(* *)
(***********************************************************************)
-(* $Id: arrayLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [ArrayLabels]: labelled Array module *)
include Array
(* *)
(***********************************************************************)
-(* $Id: arrayLabels.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Array operations. *)
external length : 'a array -> int = "%array_length"
(* *)
(***********************************************************************)
-(* $Id: buffer.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Extensible buffers *)
type t =
let rec advance i lim =
if i >= lim then lim else
match s.[i] with
- | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' |
- 'é'|'à'|'á'|'è'|'ù'|'â'|'ê'|
- 'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'|
- 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'|
- 'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' ->
- advance (i + 1) lim
+ | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim
| _ -> i in
advance start (String.length s);;
(* *)
(***********************************************************************)
-(* $Id: buffer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Extensible string buffers.
This module implements string buffers that automatically expand
(* *)
(***********************************************************************)
-(* $Id: callback.ml 11922 2011-12-21 15:37:54Z doligez $ *)
-
(* Registering OCaml values with the C runtime for later callbacks *)
external register_named_value : string -> Obj.t -> unit
(* *)
(***********************************************************************)
-(* $Id: callback.mli 12147 2012-02-10 14:45:41Z doligez $ *)
-
(** Registering OCaml values with the C runtime.
This module allows OCaml values to be registered with the C runtime
(* *)
(***********************************************************************)
-(* $Id: camlinternalLazy.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Internals of forcing lazy values. *)
exception Undefined;;
Obj.set_field (Obj.repr blk) 0 raise_undefined;
try
let result = closure () in
- Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *)
+ (* do set_field BEFORE set_tag *)
+ Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
Obj.set_tag (Obj.repr blk) Obj.forward_tag;
result
with e ->
let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
Obj.set_field (Obj.repr blk) 0 raise_undefined;
let result = closure () in
- Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *)
+ (* do set_field BEFORE set_tag *)
+ Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
result
;;
(* *)
(***********************************************************************)
-(* $Id: camlinternalLazy.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Run-time support for lazy values.
All functions in this module are for system use only, not for the
casual user. *)
(* *)
(***********************************************************************)
-(* $Id: camlinternalMod.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type shape =
| Function
| Lazy
(* *)
(***********************************************************************)
-(* $Id: camlinternalMod.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Run-time support for recursive modules.
All functions in this module are for system use only, not for the
casual user. *)
(* *)
(***********************************************************************)
-(* $Id: camlinternalOO.ml 11930 2011-12-22 07:30:18Z garrigue $ *)
-
open Obj
(**** Object representation ****)
(**** Items ****)
type item = DummyA | DummyB | DummyC of int
+let _ = [DummyA; DummyB; DummyC 0] (* to avoid warnings *)
let dummy_item = (magic () : item)
type label = int
type closure = item
type t = DummyA | DummyB | DummyC of int
+let _ = [DummyA; DummyB; DummyC 0] (* to avoid warnings *)
+
type obj = t array
external ret : (obj -> 'a) -> closure = "%identity"
(**** Sparse array ****)
-module Vars = Map.Make(struct type t = string let compare = compare end)
+module Vars =
+ Map.Make(struct type t = string let compare (x:t) y = compare x y end)
type vars = int Vars.t
-module Meths = Map.Make(struct type t = string let compare = compare end)
+module Meths =
+ Map.Make(struct type t = string let compare (x:t) y = compare x y end)
type meths = label Meths.t
-module Labs = Map.Make(struct type t = label let compare = compare end)
+module Labs =
+ Map.Make(struct type t = label let compare (x:t) y = compare x y end)
type labs = bool Labs.t
(* The compiler assumes that the first field of this structure is [size]. *)
table.initializers <- f::table.initializers
(*
-module Keys = Map.Make(struct type t = tag array let compare = compare end)
+module Keys =
+ Map.Make(struct type t = tag array let compare (x:t) y = compare x y end)
let key_map = ref Keys.empty
let get_key tags : item =
try magic (Keys.find tags !key_map : tag array)
(* *)
(***********************************************************************)
-(* $Id: camlinternalOO.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Run-time support for objects and classes.
All functions in this module are for system use only, not for the
casual user. *)
(* *)
(***********************************************************************)
-(* $Id: char.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Character operations *)
external code: char -> int = "%identity"
(* *)
(***********************************************************************)
-(* $Id: char.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Character operations. *)
external code : char -> int = "%identity"
(* *)
(***********************************************************************)
-(* $Id: complex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Complex numbers *)
type t = { re: float; im: float }
(* *)
(***********************************************************************)
-(* $Id: complex.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Complex numbers.
This module provides arithmetic operations on complex numbers.
(* *)
(***********************************************************************)
-(* $Id: digest.ml 12082 2012-01-26 22:56:48Z doligez $ *)
-
(* Message digest (MD5) *)
type t = string
(* *)
(***********************************************************************)
-(* $Id: digest.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
(** MD5 message digest.
- This module provides functions to compute 128-bit ``digests'' of
+ This module provides functions to compute 128-bit 'digests' of
arbitrary-length strings or files. The digests are of cryptographic
quality: it is very hard, given a digest, to forge a string having
that digest. The algorithm used is MD5. This module should not be
(* *)
(***********************************************************************)
-(* $Id: filename.ml 12383 2012-04-19 13:12:23Z xleroy $ *)
-
let generic_quote quotequote s =
let l = String.length s in
let b = Buffer.create (l + 20) in
| '\\' -> loop_bs (n+1) (i+1);
| c -> add_bs n; loop i
end
- and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done
+ and add_bs n = for _j = 1 to n do Buffer.add_char b '\\'; done
in
loop 0;
Buffer.contents b
if counter >= 1000 then raise e else try_name (counter + 1)
in try_name 0
-let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name) prefix suffix =
+let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name)
+ prefix suffix =
let rec try_name counter =
let name = temp_file_name temp_dir prefix suffix in
try
(* *)
(***********************************************************************)
-(* $Id: filename.mli 12275 2012-03-26 17:18:30Z frisch $ *)
-
(** Operations on file names. *)
val current_dir_name : string
*)
val open_temp_file :
- ?mode: open_flag list -> ?temp_dir: string -> string -> string -> string * out_channel
+ ?mode: open_flag list -> ?temp_dir: string -> string -> string ->
+ string * out_channel
(** Same as {!Filename.temp_file}, but returns both the name of a fresh
temporary file, and an output channel opened (atomically) on
this file. This function is more secure than [temp_file]: there
(* *)
(***********************************************************************)
-(* $Id: format.ml 11243 2011-10-25 13:13:54Z weis $ *)
-
-(* A pretty-printing facility and definition of formatters for ``parallel''
+(* A pretty-printing facility and definition of formatters for 'parallel'
(i.e. unrelated or independent) pretty-printing on multiple out channels. *)
(**************************************************************
| Pp_newline (* to force a newline inside a block *)
| Pp_if_newline (* to do something only if this very
line has been broken *)
-| Pp_open_tag of string (* opening a tag name *)
+| Pp_open_tag of tag (* opening a tag name *)
| Pp_close_tag (* closing the most recently opened tag *)
and tag = string
(* Ellipsis string. *)
mutable pp_ellipsis : string;
(* Output function. *)
- mutable pp_output_function : string -> int -> int -> unit;
+ mutable pp_out_string : string -> int -> int -> unit;
(* Flushing function. *)
- mutable pp_flush_function : unit -> unit;
+ mutable pp_out_flush : unit -> unit;
(* Output of new lines. *)
- mutable pp_output_newline : unit -> unit;
+ mutable pp_out_newline : unit -> unit;
(* Output of indentation spaces. *)
- mutable pp_output_spaces : int -> unit;
+ mutable pp_out_spaces : int -> unit;
(* Are tags printed ? *)
mutable pp_print_tags : bool;
(* Are tags marked ? *)
(* Pp_infinity: large value for default tokens size.
Pp_infinity is documented as being greater than 1e10; to avoid
- confusion about the word ``greater'', we choose pp_infinity greater
+ confusion about the word 'greater', we choose pp_infinity greater
than 1e10 + 1; for correct handling of tests in the algorithm,
pp_infinity must be even one more than 1e10 + 1; let's stand on the
safe side by choosing 1.e10+10.
let pp_infinity = 1000000010;;
(* Output functions for the formatter. *)
-let pp_output_string state s = state.pp_output_function s 0 (String.length s)
-and pp_output_newline state = state.pp_output_newline ()
-and pp_display_blanks state n = state.pp_output_spaces n
+let pp_output_string state s = state.pp_out_string s 0 (String.length s)
+and pp_output_newline state = state.pp_out_newline ()
+and pp_output_spaces state n = state.pp_out_spaces n
;;
(* To format a break, indenting a new line. *)
let real_indent = min state.pp_max_indent indent in
state.pp_current_indent <- real_indent;
state.pp_space_left <- state.pp_margin - state.pp_current_indent;
- pp_display_blanks state state.pp_current_indent
+ pp_output_spaces state state.pp_current_indent
;;
(* To force a line break inside a block: no offset is added. *)
(* To format a break that fits on the current line. *)
let break_same_line state width =
state.pp_space_left <- state.pp_space_left - width;
- pp_display_blanks state width
+ pp_output_spaces state width
;;
(* To indent no more than pp_max_indent, if one tries to open a block
(* Print a new line after printing all queued text
(same for print_flush but without a newline). *)
let pp_print_newline state () =
- pp_flush_queue state true; state.pp_flush_function ()
+ pp_flush_queue state true; state.pp_out_flush ()
and pp_print_flush state () =
- pp_flush_queue state false; state.pp_flush_function ();;
+ pp_flush_queue state false; state.pp_out_flush ();;
(* To get a newline when one does not want to close the current block. *)
let pp_force_newline state () =
let pp_get_margin state () = state.pp_margin;;
+type formatter_out_functions = {
+ out_string : string -> int -> int -> unit;
+ out_flush : unit -> unit;
+ out_newline : unit -> unit;
+ out_spaces : int -> unit;
+}
+;;
+
+let pp_set_formatter_out_functions state {
+ out_string = f;
+ out_flush = g;
+ out_newline = h;
+ out_spaces = i;
+ } =
+ state.pp_out_string <- f;
+ state.pp_out_flush <- g;
+ state.pp_out_newline <- h;
+ state.pp_out_spaces <- i;
+;;
+
+let pp_get_formatter_out_functions state () = {
+ out_string = state.pp_out_string;
+ out_flush = state.pp_out_flush;
+ out_newline = state.pp_out_newline;
+ out_spaces = state.pp_out_spaces;
+}
+;;
+
let pp_set_formatter_output_functions state f g =
- state.pp_output_function <- f; state.pp_flush_function <- g;;
+ state.pp_out_string <- f; state.pp_out_flush <- g;;
let pp_get_formatter_output_functions state () =
- (state.pp_output_function, state.pp_flush_function)
+ (state.pp_out_string, state.pp_out_flush)
;;
let pp_set_all_formatter_output_functions state
~out:f ~flush:g ~newline:h ~spaces:i =
pp_set_formatter_output_functions state f g;
- state.pp_output_newline <- h;
- state.pp_output_spaces <- i;
+ state.pp_out_newline <- h;
+ state.pp_out_spaces <- i;
;;
let pp_get_all_formatter_output_functions state () =
- (state.pp_output_function, state.pp_flush_function,
- state.pp_output_newline, state.pp_output_spaces)
+ (state.pp_out_string, state.pp_out_flush,
+ state.pp_out_newline, state.pp_out_spaces)
;;
(* Default function to output new lines. *)
-let display_newline state () = state.pp_output_function "\n" 0 1;;
+let display_newline state () = state.pp_out_string "\n" 0 1;;
(* Default function to output spaces. *)
let blank_line = String.make 80 ' ';;
let rec display_blanks state n =
if n > 0 then
- if n <= 80 then state.pp_output_function blank_line 0 n else
+ if n <= 80 then state.pp_out_string blank_line 0 n else
begin
- state.pp_output_function blank_line 0 80;
+ state.pp_out_string blank_line 0 80;
display_blanks state (n - 80)
end
;;
let pp_set_formatter_out_channel state os =
- state.pp_output_function <- output os;
- state.pp_flush_function <- (fun () -> flush os);
- state.pp_output_newline <- display_newline state;
- state.pp_output_spaces <- display_blanks state;
+ state.pp_out_string <- output os;
+ state.pp_out_flush <- (fun () -> flush os);
+ state.pp_out_newline <- display_newline state;
+ state.pp_out_spaces <- display_blanks state;
;;
(**************************************************************
let default_pp_mark_open_tag s = "<" ^ s ^ ">";;
let default_pp_mark_close_tag s = "</" ^ s ^ ">";;
-let default_pp_print_open_tag _ = ();;
-let default_pp_print_close_tag = default_pp_print_open_tag;;
+let default_pp_print_open_tag = ignore;;
+let default_pp_print_close_tag = ignore;;
let pp_make_formatter f g h i =
(* The initial state of the formatter contains a dummy box. *)
pp_curr_depth = 1;
pp_max_boxes = max_int;
pp_ellipsis = ".";
- pp_output_function = f;
- pp_flush_function = g;
- pp_output_newline = h;
- pp_output_spaces = i;
+ pp_out_string = f;
+ pp_out_flush = g;
+ pp_out_newline = h;
+ pp_out_spaces = i;
pp_print_tags = false;
pp_mark_tags = false;
pp_mark_open_tag = default_pp_mark_open_tag;
(* Make a formatter with default functions to output spaces and new lines. *)
let make_formatter output flush =
let ppf = pp_make_formatter output flush ignore ignore in
- ppf.pp_output_newline <- display_newline ppf;
- ppf.pp_output_spaces <- display_blanks ppf;
+ ppf.pp_out_newline <- display_newline ppf;
+ ppf.pp_out_spaces <- display_blanks ppf;
ppf
;;
and set_formatter_out_channel =
pp_set_formatter_out_channel std_formatter
+and set_formatter_out_functions =
+ pp_set_formatter_out_functions std_formatter
+and get_formatter_out_functions =
+ pp_get_formatter_out_functions std_formatter
+
and set_formatter_output_functions =
pp_set_formatter_output_functions std_formatter
and get_formatter_output_functions =
(* Trailer: giving up at character number ... *)
let giving_up mess fmt i =
Printf.sprintf
- "Format.fprintf: %s ``%s'', giving up at character number %d%s"
+ "Format.fprintf: %s \'%s\', giving up at character number %d%s"
mess (Sformat.to_string fmt) i
(if i < Sformat.length fmt
then Printf.sprintf " (%c)." (Sformat.get fmt i)
according to the format string.
Regular [fprintf]-like functions of this module are obtained via partial
applications of [mkprintf]. *)
-let mkprintf to_s get_out =
-
- let rec kprintf k fmt =
+let mkprintf to_s get_out k fmt =
+
+ (* [out] is global to this definition of [pr], and must be shared by all its
+ recursive calls (if any). *)
+ let out = get_out fmt in
+ let print_as = ref None in
+ let outc c =
+ match !print_as with
+ | None -> pp_print_char out c
+ | Some size ->
+ pp_print_as_size out size (String.make 1 c);
+ print_as := None
+ and outs s =
+ match !print_as with
+ | None -> pp_print_string out s
+ | Some size ->
+ pp_print_as_size out size s;
+ print_as := None
+ and flush out = pp_print_flush out () in
+
+ let rec pr k n fmt v =
let len = Sformat.length fmt in
- let kpr fmt v =
- let ppf = get_out fmt in
- let print_as = ref None in
- let pp_print_as_char c =
- match !print_as with
- | None -> pp_print_char ppf c
- | Some size ->
- pp_print_as_size ppf size (String.make 1 c);
- print_as := None
- and pp_print_as_string s =
- match !print_as with
- | None -> pp_print_string ppf s
- | Some size ->
- pp_print_as_size ppf size s;
- print_as := None in
-
- let rec doprn n i =
- if i >= len then Obj.magic (k ppf) else
- match Sformat.get fmt i with
- | '%' ->
- Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+ let rec doprn n i =
+ if i >= len then Obj.magic (k out) else
+ match Sformat.get fmt i with
+ | '%' ->
+ Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+ | '@' ->
+ let i = succ i in
+ if i >= len then invalid_format fmt i else
+ begin match Sformat.get fmt i with
+ | '[' ->
+ do_pp_open_box out n (succ i)
+ | ']' ->
+ pp_close_box out ();
+ doprn n (succ i)
+ | '{' ->
+ do_pp_open_tag out n (succ i)
+ | '}' ->
+ pp_close_tag out ();
+ doprn n (succ i)
+ | ' ' ->
+ pp_print_space out ();
+ doprn n (succ i)
+ | ',' ->
+ pp_print_cut out ();
+ doprn n (succ i)
+ | '?' ->
+ pp_print_flush out ();
+ doprn n (succ i)
+ | '.' ->
+ pp_print_newline out ();
+ doprn n (succ i)
+ | '\n' ->
+ pp_force_newline out ();
+ doprn n (succ i)
+ | ';' ->
+ do_pp_break out n (succ i)
+ | '<' ->
+ let got_size size n i =
+ print_as := Some size;
+ doprn n (skip_gt i) in
+ get_int n (succ i) got_size
| '@' ->
- let i = succ i in
- if i >= len then invalid_format fmt i else
- begin match Sformat.get fmt i with
- | '[' ->
- do_pp_open_box ppf n (succ i)
- | ']' ->
- pp_close_box ppf ();
- doprn n (succ i)
- | '{' ->
- do_pp_open_tag ppf n (succ i)
- | '}' ->
- pp_close_tag ppf ();
- doprn n (succ i)
- | ' ' ->
- pp_print_space ppf ();
- doprn n (succ i)
- | ',' ->
- pp_print_cut ppf ();
- doprn n (succ i)
- | '?' ->
- pp_print_flush ppf ();
- doprn n (succ i)
- | '.' ->
- pp_print_newline ppf ();
- doprn n (succ i)
- | '\n' ->
- pp_force_newline ppf ();
- doprn n (succ i)
- | ';' ->
- do_pp_break ppf n (succ i)
- | '<' ->
- let got_size size n i =
- print_as := Some size;
- doprn n (skip_gt i) in
- get_int n (succ i) got_size
- | '@' | '%' as c ->
- pp_print_as_char c;
- doprn n (succ i)
- | _ -> invalid_format fmt i
- end
- | c ->
- pp_print_as_char c;
+ outc '@';
doprn n (succ i)
-
- and cont_s n s i =
- pp_print_as_string s; doprn n i
- and cont_a n printer arg i =
- if to_s then
- pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg)
- else
- printer ppf arg;
- doprn n i
- and cont_t n printer i =
- if to_s then
- pp_print_as_string ((Obj.magic printer : unit -> string) ())
- else
- printer ppf;
- doprn n i
- and cont_f n i =
- pp_print_flush ppf (); doprn n i
- and cont_m n sfmt i =
- kprintf (Obj.magic (fun _ -> doprn n i)) sfmt
-
- and get_int n i c =
- if i >= len then invalid_integer fmt i else
- match Sformat.get fmt i with
- | ' ' -> get_int n (succ i) c
- | '%' ->
- let cont_s n s i = c (format_int_of_string fmt i s) n i
- and cont_a _n _printer _arg i = invalid_integer fmt i
- and cont_t _n _printer i = invalid_integer fmt i
- and cont_f _n i = invalid_integer fmt i
- and cont_m _n _sfmt i = invalid_integer fmt i in
- Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
- | _ ->
- let rec get j =
- if j >= len then invalid_integer fmt j else
- match Sformat.get fmt j with
- | '0' .. '9' | '-' -> get (succ j)
- | _ ->
- let size =
- if j = i then size_of_int 0 else
- let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
- format_int_of_string fmt j s in
- c size n j in
- get i
-
- and skip_gt i =
- if i >= len then invalid_format fmt i else
- match Sformat.get fmt i with
- | ' ' -> skip_gt (succ i)
- | '>' -> succ i
| _ -> invalid_format fmt i
-
- and get_box_kind i =
- if i >= len then Pp_box, i else
- match Sformat.get fmt i with
- | 'h' ->
+ end
+ | c -> outc c; doprn n (succ i)
+
+ and cont_s n s i =
+ outs s; doprn n i
+ and cont_a n printer arg i =
+ if to_s then
+ outs ((Obj.magic printer : unit -> _ -> string) () arg)
+ else
+ printer out arg;
+ doprn n i
+ and cont_t n printer i =
+ if to_s then
+ outs ((Obj.magic printer : unit -> string) ())
+ else
+ printer out;
+ doprn n i
+ and cont_f n i =
+ flush out; doprn n i
+ and cont_m n xf i =
+ let m =
+ Sformat.add_int_index
+ (Tformat.count_printing_arguments_of_format xf) n in
+ pr (Obj.magic (fun _ -> doprn m i)) n xf v
+
+ and get_int n i c =
+ if i >= len then invalid_integer fmt i else
+ match Sformat.get fmt i with
+ | ' ' -> get_int n (succ i) c
+ | '%' ->
+ let cont_s n s i = c (format_int_of_string fmt i s) n i
+ and cont_a _n _printer _arg i = invalid_integer fmt i
+ and cont_t _n _printer i = invalid_integer fmt i
+ and cont_f _n i = invalid_integer fmt i
+ and cont_m _n _sfmt i = invalid_integer fmt i in
+ Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+ | _ ->
+ let rec get j =
+ if j >= len then invalid_integer fmt j else
+ match Sformat.get fmt j with
+ | '0' .. '9' | '-' -> get (succ j)
+ | _ ->
+ let size =
+ if j = i then size_of_int 0 else
+ let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
+ format_int_of_string fmt j s in
+ c size n j in
+ get i
+
+ and skip_gt i =
+ if i >= len then invalid_format fmt i else
+ match Sformat.get fmt i with
+ | ' ' -> skip_gt (succ i)
+ | '>' -> succ i
+ | _ -> invalid_format fmt i
+
+ and get_box_kind i =
+ if i >= len then Pp_box, i else
+ match Sformat.get fmt i with
+ | 'h' ->
+ let i = succ i in
+ if i >= len then Pp_hbox, i else
+ begin match Sformat.get fmt i with
+ | 'o' ->
let i = succ i in
- if i >= len then Pp_hbox, i else
+ if i >= len then format_invalid_arg "bad box format" fmt i else
begin match Sformat.get fmt i with
- | 'o' ->
- let i = succ i in
- if i >= len then format_invalid_arg "bad box format" fmt i else
- begin match Sformat.get fmt i with
- | 'v' -> Pp_hovbox, succ i
- | c ->
- format_invalid_arg
- ("bad box name ho" ^ String.make 1 c) fmt i
- end
- | 'v' -> Pp_hvbox, succ i
- | _ -> Pp_hbox, i
+ | 'v' -> Pp_hovbox, succ i
+ | c ->
+ format_invalid_arg
+ ("bad box name ho" ^ String.make 1 c) fmt i
end
- | 'b' -> Pp_box, succ i
- | 'v' -> Pp_vbox, succ i
- | _ -> Pp_box, i
-
- and get_tag_name n i c =
- let rec get accu n i j =
- if j >= len then
- c (implode_rev
- (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
- accu)
- n j else
- match Sformat.get fmt j with
- | '>' ->
- c (implode_rev
- (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
- accu)
- n j
- | '%' ->
- let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
- let cont_s n s i = get (s :: s0 :: accu) n i i
- and cont_a n printer arg i =
- let s =
- if to_s
- then (Obj.magic printer : unit -> _ -> string) () arg
- else exstring printer arg in
- get (s :: s0 :: accu) n i i
- and cont_t n printer i =
- let s =
- if to_s
- then (Obj.magic printer : unit -> string) ()
- else exstring (fun ppf () -> printer ppf) () in
- get (s :: s0 :: accu) n i i
- and cont_f _n i =
- format_invalid_arg "bad tag name specification" fmt i
- and cont_m _n _sfmt i =
- format_invalid_arg "bad tag name specification" fmt i in
- Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
- | _ -> get accu n i (succ j) in
- get [] n i i
-
- and do_pp_break ppf n i =
- if i >= len then begin pp_print_space ppf (); doprn n i end else
- match Sformat.get fmt i with
- | '<' ->
- let rec got_nspaces nspaces n i =
- get_int n i (got_offset nspaces)
- and got_offset nspaces offset n i =
- pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
- doprn n (skip_gt i) in
- get_int n (succ i) got_nspaces
- | _c -> pp_print_space ppf (); doprn n i
-
- and do_pp_open_box ppf n i =
- if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
- match Sformat.get fmt i with
- | '<' ->
- let kind, i = get_box_kind (succ i) in
- let got_size size n i =
- pp_open_box_gen ppf (int_of_size size) kind;
- doprn n (skip_gt i) in
- get_int n i got_size
- | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
-
- and do_pp_open_tag ppf n i =
- if i >= len then begin pp_open_tag ppf ""; doprn n i end else
- match Sformat.get fmt i with
- | '<' ->
- let got_name tag_name n i =
- pp_open_tag ppf tag_name;
- doprn n (skip_gt i) in
- get_tag_name n (succ i) got_name
- | _c -> pp_open_tag ppf ""; doprn n i in
-
- doprn (Sformat.index_of_int 0) 0 in
-
- Tformat.kapr kpr fmt in
-
- kprintf
+ | 'v' -> Pp_hvbox, succ i
+ | _ -> Pp_hbox, i
+ end
+ | 'b' -> Pp_box, succ i
+ | 'v' -> Pp_vbox, succ i
+ | _ -> Pp_box, i
+
+ and get_tag_name n i c =
+ let rec get accu n i j =
+ if j >= len then
+ c (implode_rev
+ (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
+ accu)
+ n j else
+ match Sformat.get fmt j with
+ | '>' ->
+ c (implode_rev
+ (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
+ accu)
+ n j
+ | '%' ->
+ let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
+ let cont_s n s i = get (s :: s0 :: accu) n i i
+ and cont_a n printer arg i =
+ let s =
+ if to_s
+ then (Obj.magic printer : unit -> _ -> string) () arg
+ else exstring printer arg in
+ get (s :: s0 :: accu) n i i
+ and cont_t n printer i =
+ let s =
+ if to_s
+ then (Obj.magic printer : unit -> string) ()
+ else exstring (fun ppf () -> printer ppf) () in
+ get (s :: s0 :: accu) n i i
+ and cont_f _n i =
+ format_invalid_arg "bad tag name specification" fmt i
+ and cont_m _n _sfmt i =
+ format_invalid_arg "bad tag name specification" fmt i in
+ Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
+ | _ -> get accu n i (succ j) in
+ get [] n i i
+
+ and do_pp_break ppf n i =
+ if i >= len then begin pp_print_space ppf (); doprn n i end else
+ match Sformat.get fmt i with
+ | '<' ->
+ let rec got_nspaces nspaces n i =
+ get_int n i (got_offset nspaces)
+ and got_offset nspaces offset n i =
+ pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
+ doprn n (skip_gt i) in
+ get_int n (succ i) got_nspaces
+ | _c -> pp_print_space ppf (); doprn n i
+
+ and do_pp_open_box ppf n i =
+ if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
+ match Sformat.get fmt i with
+ | '<' ->
+ let kind, i = get_box_kind (succ i) in
+ let got_size size n i =
+ pp_open_box_gen ppf (int_of_size size) kind;
+ doprn n (skip_gt i) in
+ get_int n i got_size
+ | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
+
+ and do_pp_open_tag ppf n i =
+ if i >= len then begin pp_open_tag ppf ""; doprn n i end else
+ match Sformat.get fmt i with
+ | '<' ->
+ let got_name tag_name n i =
+ pp_open_tag ppf tag_name;
+ doprn n (skip_gt i) in
+ get_tag_name n (succ i) got_name
+ | _c -> pp_open_tag ppf ""; doprn n i in
+
+ doprn n 0 in
+
+ let kpr = pr k (Sformat.index_of_int 0) in
+
+ Tformat.kapr kpr fmt
;;
(**************************************************************
let ksprintf k =
let b = Buffer.create 512 in
let k ppf = k (string_out b ppf) in
- mkprintf true (fun _ -> formatter_of_buffer b) k
+ let ppf = formatter_of_buffer b in
+ let get_out _ = ppf in
+ mkprintf true get_out k
;;
let sprintf fmt = ksprintf (fun s -> s) fmt;;
+let asprintf fmt =
+ let b = Buffer.create 512 in
+ let k ppf = string_out b ppf in
+ let ppf = formatter_of_buffer b in
+ let get_out _ = ppf in
+ mkprintf false get_out k fmt;;
+
(**************************************************************
Deprecated stuff.
(* Deprecated alias for ksprintf. *)
let kprintf = ksprintf;;
+(* Output everything left in the pretty printer queue at end of execution. *)
at_exit print_flush
;;
(* *)
(***********************************************************************)
-(* $Id: format.mli 12906 2012-09-08 15:27:53Z doligez $ *)
-
(** Pretty printing.
This module implements a pretty-printing facility to format text
- within ``pretty-printing boxes''. The pretty-printer breaks lines
+ within 'pretty-printing boxes'. The pretty-printer breaks lines
at specified break hints, and indents lines according to the box
structure.
(** [open_box d] opens a new pretty-printing box
with offset [d].
This box is the general purpose pretty-printing box.
- Material in this box is displayed ``horizontal or vertical'':
+ Material in this box is displayed 'horizontal or vertical':
break hints inside the box may lead to a new line, if there
is no more room on the line to print the remainder of the box,
or if a new line may lead to a new indentation
(** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
val set_max_boxes : int -> unit;;
-(** [set_max_boxes max] sets the maximum number
- of boxes simultaneously opened.
- Material inside boxes nested deeper is printed as an
- ellipsis (more precisely as the text returned by
- [get_ellipsis_text ()]).
+(** [set_max_boxes max] sets the maximum number of boxes simultaneously
+ opened.
+ Material inside boxes nested deeper is printed as an ellipsis (more
+ precisely as the text returned by [get_ellipsis_text ()]).
Nothing happens if [max] is smaller than 2. *)
val get_max_boxes : unit -> int;;
val open_hbox : unit -> unit;;
(** [open_hbox ()] opens a new pretty-printing box.
- This box is ``horizontal'': the line is not split in this box
+ This box is 'horizontal': the line is not split in this box
(new lines may still occur inside boxes nested deeper). *)
val open_vbox : int -> unit;;
(** [open_vbox d] opens a new pretty-printing box
with offset [d].
- This box is ``vertical'': every break hint inside this
+ This box is 'vertical': every break hint inside this
box leads to a new line.
When a new line is printed in the box, [d] is added to the
current indentation. *)
val open_hvbox : int -> unit;;
(** [open_hvbox d] opens a new pretty-printing box
with offset [d].
- This box is ``horizontal-vertical'': it behaves as an
- ``horizontal'' box if it fits on a single line,
- otherwise it behaves as a ``vertical'' box.
+ This box is 'horizontal-vertical': it behaves as an
+ 'horizontal' box if it fits on a single line,
+ otherwise it behaves as a 'vertical' box.
When a new line is printed in the box, [d] is added to the
current indentation. *)
val open_hovbox : int -> unit;;
(** [open_hovbox d] opens a new pretty-printing box
with offset [d].
- This box is ``horizontal or vertical'': break hints
+ This box is 'horizontal or vertical': break hints
inside this box may lead to a new line, if there is no more room
on the line to print the remainder of the box.
When a new line is printed in the box, [d] is added to the
entities (e.g. HTML or TeX elements or terminal escape sequences).
By default, those tags do not influence line breaking calculation:
- the tag ``markers'' are not considered as part of the printing
+ the tag 'markers' are not considered as part of the printing
material that drives line breaking (in other words, the length of
those strings is considered as zero for line breaking).
Thus, tag handling is in some sense transparent to pretty-printing
- and does not interfere with usual pretty-printing. Hence, a single
- pretty printing routine can output both simple ``verbatim''
+ and does not interfere with usual indentation. Hence, a single
+ pretty printing routine can output both simple 'verbatim'
material or richer decorated output depending on the treatment of
tags. By default, tags are not active, hence the output is not
decorated with tag information. Once [set_tags] is set to [true],
accordingly.
When a tag has been opened (or closed), it is both and successively
- ``printed'' and ``marked''. Printing a tag means calling a
+ 'printed' and 'marked'. Printing a tag means calling a
formatter specific function with the name of the tag as argument:
- that ``tag printing'' function can then print any regular material
+ that 'tag printing' function can then print any regular material
to the formatter (so that this material is enqueued as usual in the
formatter queue for further line-breaking computation). Marking a
- tag means to output an arbitrary string (the ``tag marker''),
+ tag means to output an arbitrary string (the 'tag marker'),
directly into the output device of the formatter. Hence, the
- formatter specific ``tag marking'' function must return the tag
+ formatter specific 'tag marking' function must return the tag
marker string associated to its tag argument. Being flushed
directly into the output device of the formatter, tag marker
strings are not considered as part of the printing material that
function of the formatter is called with [t] as argument;
the tag marker [mark_open_tag t] will be flushed into the output
device of the formatter. *)
+
val close_tag : unit -> unit;;
(** [close_tag ()] closes the most recently opened tag [t].
In addition, the [print_close_tag] function of the formatter is called
(string -> int -> int -> unit) -> (unit -> unit) -> unit
;;
(** [set_formatter_output_functions out flush] redirects the
- relevant pretty-printer output functions to the functions [out] and
+ pretty-printer output functions to the functions [out] and
[flush].
- The [out] function performs the pretty-printer string output. It is called
- with a string [s], a start position [p], and a number of characters
- [n]; it is supposed to output characters [p] to [p + n - 1] of
- [s]. The [flush] function is called whenever the pretty-printer is
- flushed (via conversion [%!], pretty-printing indications [@?] or [@.],
- or using low level function [print_flush] or [print_newline]). *)
+ The [out] function performs all the pretty-printer string output.
+ It is called with a string [s], a start position [p], and a number of
+ characters [n]; it is supposed to output characters [p] to [p + n - 1] of
+ [s].
+
+ The [flush] function is called whenever the pretty-printer is flushed
+ (via conversion [%!], or pretty-printing indications [@?] or [@.], or
+ using low level functions [print_flush] or [print_newline]). *)
val get_formatter_output_functions :
unit -> (string -> int -> int -> unit) * (unit -> unit)
how to handle indentation, line breaking, and even printing of all the
characters that have to be printed! *)
-val set_all_formatter_output_functions :
- out:(string -> int -> int -> unit) ->
- flush:(unit -> unit) ->
- newline:(unit -> unit) ->
- spaces:(int -> unit) ->
- unit
+type formatter_out_functions = {
+ out_string : string -> int -> int -> unit;
+ out_flush : unit -> unit;
+ out_newline : unit -> unit;
+ out_spaces : int -> unit;
+}
;;
-(** [set_all_formatter_output_functions out flush outnewline outspace]
- redirects the pretty-printer output to the functions [out] and
- [flush] as described in [set_formatter_output_functions]. In
- addition, the pretty-printer function that outputs a newline is set
- to the function [outnewline] and the function that outputs
- indentation spaces is set to the function [outspace].
- This way, you can change the meaning of indentation (which can be
- something else than just printing space characters) and the
- meaning of new lines opening (which can be connected to any other
- action needed by the application at hand). The two functions
- [outspace] and [outnewline] are normally connected to [out] and
- [flush]: respective default values for [outspace] and [outnewline]
- are [out (String.make n ' ') 0 n] and [out "\n" 0 1]. *)
+val set_formatter_out_functions : formatter_out_functions -> unit;;
+(** [set_formatter_out_functions out_funs]
+ Redirect the pretty-printer output to the functions [out_funs.out_string]
+ and [out_funs.out_flush] as described in
+ [set_formatter_output_functions]. In addition, the pretty-printer function
+ that outputs a newline is set to the function [out_funs.out_newline] and
+ the function that outputs indentation spaces is set to the function
+ [out_funs.out_spaces].
-val get_all_formatter_output_functions :
- unit ->
- (string -> int -> int -> unit) *
- (unit -> unit) *
- (unit -> unit) *
- (int -> unit)
-;;
+ This way, you can change the meaning of indentation (which can be
+ something else than just printing space characters) and the meaning of new
+ lines opening (which can be connected to any other action needed by the
+ application at hand). The two functions [out_spaces] and [out_newline] are
+ normally connected to [out_string] and [out_flush]: respective default
+ values for [out_space] and [out_newline] are
+ [out_string (String.make n ' ') 0 n] and [out_string "\n" 0 1]. *)
+
+val get_formatter_out_functions : unit -> formatter_out_functions;;
(** Return the current output functions of the pretty-printer,
including line breaking and indentation functions. Useful to record the
current setting and restore it afterwards. *)
}
;;
(** The tag handling functions specific to a formatter:
- [mark] versions are the ``tag marking'' functions that associate a string
+ [mark] versions are the 'tag marking' functions that associate a string
marker to a tag in order for the pretty-printing engine to flush
those markers as 0 length tokens in the output device of the formatter.
- [print] versions are the ``tag printing'' functions that can perform
+ [print] versions are the 'tag printing' functions that can perform
regular printing when a tag is closed or opened. *)
-val set_formatter_tag_functions :
- formatter_tag_functions -> unit
-;;
-
+val set_formatter_tag_functions : formatter_tag_functions -> unit;;
(** [set_formatter_tag_functions tag_funs] changes the meaning of
opening and closing tags to use the functions in [tag_funs].
called at tag opening and tag closing time, to output regular
material in the pretty-printer queue. *)
-val get_formatter_tag_functions :
- unit -> formatter_tag_functions
-;;
+val get_formatter_tag_functions : unit -> formatter_tag_functions;;
(** Return the current tag functions of the pretty-printer. *)
(** {6 Multiple formatted output} *)
val pp_over_max_boxes : formatter -> unit -> bool;;
val pp_set_ellipsis_text : formatter -> string -> unit;;
val pp_get_ellipsis_text : formatter -> unit -> string;;
-val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit;;
+val pp_set_formatter_out_channel :
+ formatter -> Pervasives.out_channel -> unit
+;;
val pp_set_formatter_output_functions :
formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
;;
val pp_get_formatter_output_functions :
formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
;;
-val pp_set_all_formatter_output_functions :
- formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
- newline:(unit -> unit) -> spaces:(int -> unit) -> unit
-;;
-val pp_get_all_formatter_output_functions :
- formatter -> unit ->
- (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
- (int -> unit)
-;;
val pp_set_formatter_tag_functions :
formatter -> formatter_tag_functions -> unit
;;
val pp_get_formatter_tag_functions :
formatter -> unit -> formatter_tag_functions
;;
+val pp_set_formatter_out_functions :
+ formatter -> formatter_out_functions -> unit
+;;
+val pp_get_formatter_out_functions :
+ formatter -> unit -> formatter_out_functions
+;;
(** These functions are the basic ones: usual functions
operating on the standard formatter are defined via partial
evaluation of these primitives. For instance,
then an optional integer offset, and the closing [>] character.
Box type is one of [h], [v], [hv], [b], or [hov],
which stand respectively for an horizontal box, a vertical box,
- an ``horizontal-vertical'' box, or an ``horizontal or
- vertical'' box ([b] standing for an ``horizontal or
- vertical'' box demonstrating indentation and [hov] standing
- for a regular``horizontal or vertical'' box).
- For instance, [@\[<hov 2>] opens an ``horizontal or vertical''
+ an 'horizontal-vertical' box, or an 'horizontal or
+ vertical' box ([b] standing for an 'horizontal or
+ vertical' box demonstrating indentation and [hov] standing
+ for a regular'horizontal or vertical' box).
+ For instance, [@\[<hov 2>] opens an 'horizontal or vertical'
box with indentation 2 as obtained with [open_hovbox 2].
For more details about boxes, see the various box opening
functions [open_*box].
- [@\]]: close the most recently opened pretty-printing box.
- - [@,]: output a good break as with [print_cut ()].
- - [@ ]: output a space, as with [print_space ()].
- - [@\n]: force a newline, as with [force_newline ()].
- - [@;]: output a good break as with [print_break]. The
+ - [@,]: output a good break hint, as with [print_cut ()].
+ - [@ ]: output a good break space, as with [print_space ()].
+ - [@;]: output a fully specified good break as with [print_break]. The
[nspaces] and [offset] parameters of the break may be
optionally specified with the following syntax:
the [<] character, followed by an integer [nspaces] value,
then an integer [offset], and a closing [>] character.
If no parameters are provided, the good break defaults to a
- space.
- - [@?]: flush the pretty printer as with [print_flush ()].
- This is equivalent to the conversion [%!].
+ good break space.
- [@.]: flush the pretty printer and output a new line, as with
[print_newline ()].
- [@<n>]: print the following item as if it were of length [n].
For more details about tags, see the functions [open_tag] and
[close_tag].
- [@\}]: close the most recently opened tag.
+ - [@?]: flush the pretty printer as with [print_flush ()].
+ This is equivalent to the conversion [%!].
+ - [@\n]: force a newline, as with [force_newline ()].
+ - [@@]: print a single [@] character.
Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to
[open_box (); print_string "x ="; print_space ();
print_int 1; close_box (); print_newline ()].
It prints [x = 1] within a pretty-printing box.
- Note: the old [@@] ``pretty-printing indication'' is now deprecated, since
- it had no pretty-printing indication semantics. If you need to prevent
- the pretty-printing indication interpretation of a [@] character, simply
- use the regular way to escape a character in format string: write [%@].
- @since 3.12.2.
+ Note: If you need to prevent the interpretation of a [@] character as a
+ pretty-printing indication, escape it with a [%] character, as usual in
+ format strings.
+ @since 3.12.2
*)
Alternatively, you can use [Format.fprintf] with a formatter writing to a
buffer of your own: flushing the formatter and the buffer at the end of
- pretty-printing returns the desired string. *)
+ pretty-printing returns the desired string.
+*)
+
+val asprintf : ('a, formatter, unit, string) format4 -> 'a;;
+(** Same as [printf] above, but instead of printing on a formatter,
+ returns a string containing the result of formatting the arguments.
+ The type of [asprintf] is general enough to interact nicely with [%a]
+ conversions.
+ @since 4.01.0
+ *)
val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;;
(** Same as [fprintf] above, but does not print anything.
val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
(** A deprecated synonym for [ksprintf]. *)
+
+val set_all_formatter_output_functions :
+ out:(string -> int -> int -> unit) ->
+ flush:(unit -> unit) ->
+ newline:(unit -> unit) ->
+ spaces:(int -> unit) ->
+ unit
+;;
+(** Deprecated. Subsumed by [set_formatter_out_functions].
+ @since 4.00.0
+*)
+
+val get_all_formatter_output_functions :
+ unit ->
+ (string -> int -> int -> unit) *
+ (unit -> unit) *
+ (unit -> unit) *
+ (int -> unit)
+;;
+(** Deprecated. Subsumed by [get_formatter_out_functions].
+ @since 4.00.0
+*)
+val pp_set_all_formatter_output_functions :
+ formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
+ newline:(unit -> unit) -> spaces:(int -> unit) -> unit
+;;
+(** Deprecated. Subsumed by [pp_set_formatter_out_functions].
+ @since 4.01.0
+*)
+
+val pp_get_all_formatter_output_functions :
+ formatter -> unit ->
+ (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
+ (int -> unit)
+;;
+(** Deprecated. Subsumed by [pp_get_formatter_out_functions].
+ @since 4.01.0
+*)
(* *)
(***********************************************************************)
-(* $Id: gc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type stat = {
minor_words : float;
promoted_words : float;
(* *)
(***********************************************************************)
-(* $Id: gc.mli 12339 2012-04-11 03:51:09Z frisch $ *)
-
(** Memory management control and statistics; finalised values. *)
type stat =
(* *)
(***********************************************************************)
-(* $Id: genlex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type token =
Kwd of string
| Ident of string
| String of string
| Char of char
-
(* The string buffering machinery *)
let initial_buffer = String.create 32
Some '\'' -> Stream.junk strm__; Some (Char c)
| _ -> raise (Stream.Error "")
end
- | Some '"' ->
+ | Some '\"' ->
Stream.junk strm__;
let s = strm__ in reset_buffer (); Some (String (string s))
| Some '-' -> Stream.junk strm__; neg_number strm__
| _ -> Some (Float (float_of_string (get_string ())))
and string (strm__ : _ Stream.t) =
match Stream.peek strm__ with
- Some '"' -> Stream.junk strm__; get_string ()
+ Some '\"' -> Stream.junk strm__; get_string ()
| Some '\\' ->
Stream.junk strm__;
let c =
(* *)
(***********************************************************************)
-(* $Id: genlex.mli 12210 2012-03-08 19:52:03Z doligez $ *)
-
(** A generic lexical analyzer.
- This module implements a simple ``standard'' lexical analyzer, presented
+ This module implements a simple 'standard' lexical analyzer, presented
as a function from character streams to token streams. It implements
roughly the lexical conventions of OCaml, but is parameterized by the
set of keywords of your language.
to, for instance, [int], and would have rules such as:
{[
- let parse_expr = parser
- [< 'Int n >] -> n
- | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n
- | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2
+ let rec parse_expr = parser
+ | [< n1 = parse_atom; n2 = parse_remainder n1 >] -> n2
+ and parse_atom = parser
+ | [< 'Int n >] -> n
+ | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n
and parse_remainder n1 = parser
- [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
- | ...
+ | [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
+ | [< >] -> n1
]}
One should notice that the use of the [parser] keyword and associated
string literals, enclosed in double quotes; [Char] for
character literals, enclosed in single quotes; [Ident] for
identifiers (either sequences of letters, digits, underscores
- and quotes, or sequences of ``operator characters'' such as
+ and quotes, or sequences of 'operator characters' such as
[+], [*], etc); and [Kwd] for keywords (either identifiers or
- single ``special characters'' such as [(], [}], etc). *)
+ single 'special characters' such as [(], [}], etc). *)
type token =
Kwd of string
| Ident of string
belongs to this list, and as [Ident s] otherwise.
A special character [s] is returned as [Kwd s] if [s]
belongs to this list, and cause a lexical error (exception
- [Parse_error]) otherwise. Blanks and newlines are skipped.
- Comments delimited by [(*] and [*)] are skipped as well,
- and can be nested. *)
+ [Stream.Error] with the offending lexeme as its parameter) otherwise.
+ Blanks and newlines are skipped. Comments delimited by [(*] and [*)]
+ are skipped as well, and can be nested. A [Stream.Failure] exception
+ is raised if end of stream is unexpectedly reached.*)
(* *)
(***********************************************************************)
-(* $Id: hashtbl.ml 12475 2012-05-24 14:55:00Z doligez $ *)
-
(* Hash tables *)
-external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" "noalloc"
-external old_hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
+external seeded_hash_param :
+ int -> int -> int -> 'a -> int = "caml_hash" "noalloc"
+external old_hash_param :
+ int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
let hash x = seeded_hash_param 10 100 0 x
let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
(* *)
(***********************************************************************)
-(* $Id: hashtbl.mli 12453 2012-05-15 08:44:18Z lefessan $ *)
-
(** Hash tables and hash functions.
Hash tables are hashed association tables, with in-place modification.
/* */
/***********************************************************************/
-/* $Id: header.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* The launcher for bytecode executables (if #! is not working) */
#include <stdio.h>
/* */
/***********************************************************************/
-/* $Id: headernt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#define STRICT
#define WIN32_LEAN_AND_MEAN
DWORD numwritten;
errh = GetStdHandle(STD_ERROR_HANDLE);
WriteFile(errh, truename, strlen(truename), &numwritten, NULL);
- WriteFile(errh, msg_and_length(" not found or is not a bytecode executable file\r\n"),
+ WriteFile(errh, msg_and_length(" not found or is not a bytecode"
+ " executable file\r\n"),
&numwritten, NULL);
ExitProcess(2);
#if _MSC_VER >= 1200
(* *)
(***********************************************************************)
-(* $Id: int32.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [Int32]: 32-bit integers *)
external neg : int32 -> int32 = "%int32_neg"
(* *)
(***********************************************************************)
-(* $Id: int32.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** 32-bit integers.
This module provides operations on the type [int32]
external bits_of_float : float -> int32 = "caml_int32_bits_of_float"
(** Return the internal representation of the given float according
- to the IEEE 754 floating-point ``single format'' bit layout.
+ to the IEEE 754 floating-point 'single format' bit layout.
Bit 31 of the result represents the sign of the float;
bits 30 to 23 represent the (biased) exponent; bits 22 to 0
represent the mantissa. *)
external float_of_bits : int32 -> float = "caml_int32_float_of_bits"
(** Return the floating-point number whose internal representation,
- according to the IEEE 754 floating-point ``single format'' bit layout,
+ according to the IEEE 754 floating-point 'single format' bit layout,
is the given [int32]. *)
type t = int32
(* *)
(***********************************************************************)
-(* $Id: int64.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [Int64]: 64-bit integers *)
external neg : int64 -> int64 = "%int64_neg"
(* *)
(***********************************************************************)
-(* $Id: int64.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** 64-bit integers.
This module provides operations on the type [int64] of
external bits_of_float : float -> int64 = "caml_int64_bits_of_float"
(** Return the internal representation of the given float according
- to the IEEE 754 floating-point ``double format'' bit layout.
+ to the IEEE 754 floating-point 'double format' bit layout.
Bit 63 of the result represents the sign of the float;
bits 62 to 52 represent the (biased) exponent; bits 51 to 0
represent the mantissa. *)
external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
(** Return the floating-point number whose internal representation,
- according to the IEEE 754 floating-point ``double format'' bit layout,
+ according to the IEEE 754 floating-point 'double format' bit layout,
is the given [int64]. *)
type t = int64
(* *)
(***********************************************************************)
-(* $Id: lazy.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
(* Module [Lazy]: deferred computations *)
(* *)
(***********************************************************************)
-(* $Id: lazy.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Deferred computations. *)
type 'a t = 'a lazy_t;;
(* *)
(***********************************************************************)
-(* $Id: lexing.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The run-time library for lexers generated by camllex *)
type position = {
(* *)
(***********************************************************************)
-(* $Id: lexing.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** The run-time library for lexers generated by [ocamllex]. *)
(** {6 Positions} *)
(* *)
(***********************************************************************)
-(* $Id: list.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* List operations *)
let rec length_aux len = function
(* *)
(***********************************************************************)
-(* $Id: list.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
(** List operations.
Some functions are flagged as not tail-recursive. A tail-recursive
(* *)
(***********************************************************************)
-(* $Id: listLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [ListLabels]: labelled List module *)
include List
(* *)
(***********************************************************************)
-(* $Id: listLabels.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
(** List operations.
Some functions are flagged as not tail-recursive. A tail-recursive
(* *)
(***********************************************************************)
-(* $Id: map.ml 12510 2012-05-30 11:28:51Z scherer $ *)
-
module type OrderedType =
sig
type t
val add: key -> 'a -> 'a t -> 'a t
val singleton: key -> 'a -> 'a t
val remove: key -> 'a t -> 'a t
- val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+ val merge:
+ (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val iter: (key -> 'a -> unit) -> 'a t -> unit
(* *)
(***********************************************************************)
-(* $Id: map.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Association tables over ordered types.
This module implements applicative association tables, also known as
(* *)
(***********************************************************************)
-(* $Id: marshal.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
type extern_flags =
No_sharing
| Closures
+ | Compat_32
(* note: this type definition is used in 'byterun/debugger.c' *)
external to_channel: out_channel -> 'a -> extern_flags list -> unit
(* *)
(***********************************************************************)
-(* $Id: marshal.mli 11922 2011-12-21 15:37:54Z doligez $ *)
-
(** Marshaling of data structures.
This module provides functions to encode arbitrary data structures
Anything can happen at run-time if the object in the file does not
belong to the given type.
+ OCaml exception values (of type [exn]) returned by the unmarhsaller
+ should not be pattern-matched over through [match ... with] or [try
+ ... with], because unmarshalling does not preserve the information
+ required for matching their exception constructor. Structural
+ equalities with other exception values, or most other uses such as
+ Printexc.to_string, will still work as expected.
+
The representation of marshaled values is not human-readable,
and uses bytes that are not printable characters. Therefore,
input and output channels used in conjunction with [Marshal.to_channel]
type extern_flags =
No_sharing (** Don't preserve sharing *)
| Closures (** Send function closures *)
+ | Compat_32 (** Ensure 32-bit compatibility *)
(** The flags to the [Marshal.to_*] functions below. *)
val to_channel : out_channel -> 'a -> extern_flags list -> unit
(** [Marshal.to_channel chan v flags] writes the representation
of [v] on channel [chan]. The [flags] argument is a
possibly empty list of flags that governs the marshaling
- behavior with respect to sharing and functional values.
+ behavior with respect to sharing, functional values, and compatibility
+ between 32- and 64-bit platforms.
If [flags] does not contain [Marshal.No_sharing], circularities
and sharing inside the value [v] are detected and preserved
in the sequence of bytes produced. In particular, this
guarantees that marshaling always terminates. Sharing
between values marshaled by successive calls to
- [Marshal.to_channel] is not detected, though.
+ [Marshal.to_channel] is neither detected nor preserved, though.
If [flags] contains [Marshal.No_sharing], sharing is ignored.
This results in faster marshaling if [v] contains no shared
substructures, but may cause slower marshaling and larger
If [flags] does not contain [Marshal.Closures],
marshaling fails when it encounters a functional value
- inside [v]: only ``pure'' data structures, containing neither
+ inside [v]: only 'pure' data structures, containing neither
functions nor objects, can safely be transmitted between
different programs. If [flags] contains [Marshal.Closures],
functional values will be marshaled as a position in the code
only be read back in processes that run exactly the same program,
with exactly the same compiled code. (This is checked
at un-marshaling time, using an MD5 digest of the code
- transmitted along with the code position.) *)
+ transmitted along with the code position.)
+
+ If [flags] contains [Marshal.Compat_32], marshaling fails when
+ it encounters an integer value outside the range [[-2{^30}, 2{^30}-1]]
+ of integers that are representable on a 32-bit platform. This
+ ensures that marshaled data generated on a 64-bit platform can be
+ safely read back on a 32-bit platform. If [flags] does not
+ contain [Marshal.Compat_32], integer values outside the
+ range [[-2{^30}, 2{^30}-1]] are marshaled, and can be read back on
+ a 64-bit platform, but will cause an error at un-marshaling time
+ when read back on a 32-bit platform. The [Mashal.Compat_32] flag
+ only matters when marshaling is performed on a 64-bit platform;
+ it has no effect if marshaling is performed on a 32-bit platform.
+ *)
external to_string :
'a -> extern_flags list -> string = "caml_output_value_to_string"
(* *)
(***********************************************************************)
-(* $Id: moreLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [MoreLabels]: meta-module for compatibility labelled libraries *)
module Hashtbl = Hashtbl
(* *)
(***********************************************************************)
-(* $Id: moreLabels.mli 12453 2012-05-15 08:44:18Z lefessan $ *)
-
(** Extra labeled libraries.
This meta-module provides labelized version of the {!Hashtbl},
val add : key:key -> data:'a -> 'a t -> 'a t
val singleton: key -> 'a -> 'a t
val remove : key -> 'a t -> 'a t
- val merge: f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+ val merge:
+ f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
val max_elt : t -> elt
val choose : t -> elt
val split: elt -> t -> t * bool * t
+ val find: elt -> t -> elt
end
module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
end
(* *)
(***********************************************************************)
-(* $Id: nativeint.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [Nativeint]: processor-native integers *)
external neg: nativeint -> nativeint = "%nativeint_neg"
(* *)
(***********************************************************************)
-(* $Id: nativeint.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Processor-native integers.
This module provides operations on the type [nativeint] of
(** Integer remainder. If [y] is not zero, the result
of [Nativeint.rem x y] satisfies the following properties:
[Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and
- [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) (Nativeint.rem x y)].
+ [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y)
+ (Nativeint.rem x y)].
If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *)
val succ : nativeint -> nativeint
(* *)
(***********************************************************************)
-(* $Id: obj.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Operations on internal representations of values *)
type t
(* *)
(***********************************************************************)
-(* $Id: obj.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Operations on internal representations of values.
Not for the casual user.
(* *)
(***********************************************************************)
-(* $Id: oo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
let copy = CamlinternalOO.copy
external id : < .. > -> int = "%field1"
let new_method = CamlinternalOO.public_method_label
(* *)
(***********************************************************************)
-(* $Id: oo.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Operations on objects *)
val copy : (< .. > as 'a) -> 'a
(* *)
(***********************************************************************)
-(* $Id: parsing.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The parsing engine *)
open Lexing
| Compute_semantic_action
| Call_error_function
+(* to avoid warnings *)
+let _ = [Read_token; Raise_parse_error; Grow_stacks_1; Grow_stacks_2;
+ Compute_semantic_action; Call_error_function]
+
external parse_engine :
parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output
= "caml_parse_engine"
(* *)
(***********************************************************************)
-(* $Id: parsing.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** The run-time library for parsers generated by [ocamlyacc]. *)
val symbol_start : unit -> int
(* *)
(***********************************************************************)
-(* $Id: pervasives.ml 12019 2012-01-12 15:46:51Z doligez $ *)
-
(* type 'a option = None | Some of 'a *)
(* Exceptions *)
exception Exit
+(* Composition operators *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
(* Comparisons *)
external ( = ) : 'a -> 'a -> bool = "%equal"
(* *)
(***********************************************************************)
-(* $Id: pervasives.mli 12416 2012-05-02 14:39:52Z doligez $ *)
-
(** The initially opened module.
This module provides the basic operations over the built-in types
exception Exit
(** The [Exit] exception is not raised by any library function. It is
- provided for use in your programs.*)
+ provided for use in your programs. *)
(** {6 Comparisons} *)
(** The boolean negation. *)
external ( && ) : bool -> bool -> bool = "%sequand"
-(** The boolean ``and''. Evaluation is sequential, left-to-right:
+(** The boolean 'and'. Evaluation is sequential, left-to-right:
in [e1 && e2], [e1] is evaluated first, and if it returns [false],
[e2] is not evaluated at all. *)
(** @deprecated {!Pervasives.( && )} should be used instead. *)
external ( || ) : bool -> bool -> bool = "%sequor"
-(** The boolean ``or''. Evaluation is sequential, left-to-right:
+(** The boolean 'or'. Evaluation is sequential, left-to-right:
in [e1 || e2], [e1] is evaluated first, and if it returns [true],
[e2] is not evaluated at all. *)
(** @deprecated {!Pervasives.( || )} should be used instead.*)
+(** {6 Composition operators} *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+(** Reverse-application operator: [x |> f |> g] is exactly equivalent
+ to [g (f (x))].
+ @since 4.01
+*)
+
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+(** Application operator: [g @@ f @@ x] is exactly equivalent to
+ [g (f (x))].
+ @since 4.01
+*)
+
(** {6 Integer arithmetic} *)
(** Integers are 31 bits wide (or 63 bits on 64-bit processors).
Floating-point operations never raise an exception on overflow,
underflow, division by zero, etc. Instead, special IEEE numbers
are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
- [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'')
+ [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
for [0.0 /. 0.0]. These special numbers then propagate through
floating-point computations as expected: for instance,
[1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
val nan : float
(** A special floating-point value denoting the result of an
undefined operation such as [0.0 /. 0.0]. Stands for
- ``not a number''. Any floating-point operation with [nan] as
+ 'not a number'. Any floating-point operation with [nan] as
argument returns [nan] as result. As for floating-point comparisons,
[=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
if one or both of their arguments is [nan]. *)
(** Open the named file for writing, and return a new output channel
on that file, positionned at the beginning of the file. The
file is truncated to zero length if it already exists. It
- is created if it does not already exists.
- Raise [Sys_error] if the file could not be opened. *)
+ is created if it does not already exists. *)
val open_out_bin : string -> out_channel
(** Same as {!Pervasives.open_out}, but the file is opened in binary mode,
val open_in : string -> in_channel
(** Open the named file for reading, and return a new input channel
- on that file, positionned at the beginning of the file.
- Raise [Sys_error] if the file could not be opened. *)
+ on that file, positionned at the beginning of the file. *)
val open_in_bin : string -> in_channel
(** Same as {!Pervasives.open_in}, but the file is opened in binary mode,
(** Close the given channel. Input functions raise a [Sys_error]
exception when they are applied to a closed input channel,
except [close_in], which does nothing when applied to an already
- closed channel. Note that [close_in] may raise [Sys_error] if
- the operating system signals an error. *)
+ closed channel. *)
val close_in_noerr : in_channel -> unit
(** Same as [close_in], but ignore all errors. *)
(** {6 Operations on format strings} *)
-(** Format strings are used to read and print data using formatted input
- functions in module {!Scanf} and formatted output in modules {!Printf} and
- {!Format}. *)
+(** Format strings are character strings with special lexical conventions
+ that defines the functionality of formatted input/output functions. Format
+ strings are used to read data with formatted input functions from module
+ {!Scanf} and to print data with formatted output functions from modules
+ {!Printf} and {!Format}.
+
+ Format strings are made of three kinds of entities:
+ - {e conversions specifications}, introduced by the special character ['%']
+ followed by one or more characters specifying what kind of argument to
+ read or print,
+ - {e formatting indications}, introduced by the special character ['@']
+ followed by one or more characters specifying how to read or print the
+ argument,
+ - {e plain characters} that are regular characters with usual lexical
+ conventions. Plain characters specify string literals to be read in the
+ input or printed in the output.
+
+ There is an additional lexical rule to escape the special characters ['%']
+ and ['@'] in format strings: if a special character follows a ['%']
+ character, it is treated as a plain character. In other words, ["%%"] is
+ considered as a plain ['%'] and ["%@"] as a plain ['@'].
+
+ For more information about conversion specifications and formatting
+ indications available, read the documentation of modules {!Scanf},
+ {!Printf} and {!Format}.
+*)
(** Format strings have a general and highly polymorphic type
[('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
The two simplified types, [format] and [format4] below are
- included for backward compatibility with earlier releases of OCaml.
- ['a] is the type of the parameters of the format,
- ['b] is the type of the first argument given to
- [%a] and [%t] printing functions,
- ['c] is the type of the result of the [%a] and [%t] functions, and
- also the type of the argument transmitted to the first argument
- of [kprintf]-style functions,
- ['d] is the result type for the [scanf]-style functions,
- ['e] is the type of the receiver function for the [scanf]-style functions,
- ['f] is the result type for the [printf]-style function.
- *)
+ included for backward compatibility with earlier releases of
+ OCaml.
+
+ The meaning of format string type parameters is as follows:
+
+ - ['a] is the type of the parameters of the format for formatted output
+ functions ([printf]-style functions);
+ ['a] is the type of the values read by the format for formatted input
+ functions ([scanf]-style functions).
+
+ - ['b] is the type of input source for formatted input functions and the
+ type of output target for formatted output functions.
+ For [printf]-style functions from module [Printf], ['b] is typically
+ [out_channel];
+ for [printf]-style functions from module [Format], ['b] is typically
+ [Format.formatter];
+ for [scanf]-style functions from module [Scanf], ['b] is typically
+ [Scanf.Scanning.in_channel].
+
+ Type argument ['b] is also the type of the first argument given to
+ user's defined printing functions for [%a] and [%t] conversions,
+ and user's defined reading functions for [%r] conversion.
+
+ - ['c] is the type of the result of the [%a] and [%t] printing
+ functions, and also the type of the argument transmitted to the
+ first argument of [kprintf]-style functions or to the
+ [kscanf]-style functions.
+
+ - ['d] is the type of parameters for the [scanf]-style functions.
+
+ - ['e] is the type of the receiver function for the [scanf]-style functions.
+
+ - ['f] is the final result type of a formatted input/output function
+ invocation: for the [printf]-style functions, it is typically [unit];
+ for the [scanf]-style functions, it is typically the result type of the
+ receiver function.
+*)
type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
('a, 'b, 'c, 'd, 'e, 'f) format6 ->
('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
(** [format_of_string s] returns a format string read from the string
- literal [s]. *)
+ literal [s].
+ Note: [format_of_string] can not convert a string argument that is not a
+ literal. If you need this functionality, use the more general
+ {!Scanf.format_from_string} function.
+*)
val ( ^^ ) :
('a, 'b, 'c, 'd, 'e, 'f) format6 ->
('f, 'b, 'c, 'e, 'g, 'h) format6 ->
('a, 'b, 'c, 'd, 'g, 'h) format6
-(** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format
- that accepts arguments from [f1], then arguments from [f2]. *)
+(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
+ format string that behaves as the concatenation of format strings [f1] and
+ [f2]: in case of formatted output, it accepts arguments from [f1], then
+ arguments from [f2]; in case of formatted input, it returns results from
+ [f1], then results from [f2].
+*)
(** {6 Program termination} *)
termination time. The functions registered with [at_exit]
will be called when the program executes {!Pervasives.exit},
or terminates, either normally or because of an uncaught exception.
- The functions are called in ``last in, first out'' order:
+ The functions are called in 'last in, first out' order:
the function most recently added with [at_exit] is called first. *)
(**/**)
(* *)
(***********************************************************************)
-(* $Id: printexc.ml 11187 2011-09-08 08:34:43Z xclerc $ *)
-
open Printf;;
let printers = ref []
sprintf locfmt file line char (char+6) "Undefined recursive module"
| _ ->
let x = Obj.repr x in
- let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
+ let constructor =
+ (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
constructor ^ (fields x) in
conv !printers
eprintf "Uncaught exception: %s\n" (to_string x);
exit 2
+type raw_backtrace
+
+external get_raw_backtrace:
+ unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
+
type loc_info =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* end char *)
| Unknown_location of bool (*is_raise*)
-external get_exception_backtrace:
- unit -> loc_info array option = "caml_get_exception_backtrace"
+(* to avoid warning *)
+let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
+
+type backtrace = loc_info array
+
+external convert_raw_backtrace:
+ raw_backtrace -> backtrace option = "caml_convert_raw_backtrace"
let format_loc_info pos li =
let is_raise =
sprintf "%s unknown location"
info
-let print_backtrace outchan =
- match get_exception_backtrace() with
+let print_exception_backtrace outchan backtrace =
+ match backtrace with
| None ->
fprintf outchan
"(Program not linked with -g, cannot print stack backtrace)\n"
fprintf outchan "%s\n" (format_loc_info i a.(i))
done
-let get_backtrace () =
- match get_exception_backtrace() with
+let print_raw_backtrace outchan raw_backtrace =
+ print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
+
+(* confusingly named: prints the global current backtrace *)
+let print_backtrace outchan =
+ print_raw_backtrace outchan (get_raw_backtrace ())
+
+let backtrace_to_string backtrace =
+ match backtrace with
| None ->
"(Program not linked with -g, cannot print stack backtrace)\n"
| Some a ->
done;
Buffer.contents b
+let raw_backtrace_to_string raw_backtrace =
+ backtrace_to_string (convert_raw_backtrace raw_backtrace)
+
+(* confusingly named:
+ returns the *string* corresponding to the global current backtrace *)
+let get_backtrace () =
+ (* we could use the caml_get_exception_backtrace primitive here, but
+ we hope to deprecate it so it's better to just compose the
+ raw stuff *)
+ backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
+
external record_backtrace: bool -> unit = "caml_record_backtrace"
external backtrace_status: unit -> bool = "caml_backtrace_status"
let register_printer fn =
printers := fn :: !printers
+
+
+external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
(* *)
(***********************************************************************)
-(* $Id: printexc.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
-(** Facilities for printing exceptions. *)
+(** Facilities for printing exceptions and inspecting current call stack. *)
val to_string: exn -> string
(** [Printexc.to_string e] returns a string representation of
the backtrace if it has itself raised an exception before.
@since 3.11.2
*)
+
+(** {6 Raw backtraces} *)
+
+type raw_backtrace
+
+(** The abstract type [backtrace] stores exception backtraces in
+ a low-level format, instead of directly exposing them as string as
+ the [get_backtrace()] function does.
+
+ This allows to pay the performance overhead of representation
+ conversion and formatting only at printing time, which is useful
+ if you want to record more backtrace than you actually print.
+*)
+
+val get_raw_backtrace: unit -> raw_backtrace
+val print_raw_backtrace: out_channel -> raw_backtrace -> unit
+val raw_backtrace_to_string: raw_backtrace -> string
+
+
+(** {6 Current call stack} *)
+
+val get_callstack: int -> raw_backtrace
+
+(** [Printexc.get_callstack n] returns a description of the top of the
+ call stack on the current program point (for the current thread),
+ with at most [n] entries. (Note: this function is not related to
+ exceptions at all, despite being part of the [Printexc] module.)
+
+ @since 4.01.0
+*)
(* *)
(***********************************************************************)
-(* $Id: printf.ml 12014 2012-01-11 15:22:51Z doligez $ *)
-
external format_float: string -> float -> string
= "caml_format_float"
external format_int: string -> int -> string
let bad_conversion sfmt i c =
invalid_arg
("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^
- string_of_int i ^ " in format string ``" ^ sfmt ^ "''")
+ string_of_int i ^ " in format string \'" ^ sfmt ^ "\'")
;;
let bad_conversion_format fmt i c =
let incomplete_format fmt =
invalid_arg
- ("Printf: premature end of format string ``" ^
- Sformat.to_string fmt ^ "''")
+ ("Printf: premature end of format string \'" ^
+ Sformat.to_string fmt ^ "\'")
;;
-(* Parses a string conversion to return the specified length and the padding direction. *)
+(* Parses a string conversion to return the specified length and the
+ padding direction. *)
let parse_string_conversion sfmt =
let rec parse neg i =
if i >= String.length sfmt then (0, neg) else
;;
let extract_format_int conv fmt start stop widths =
- let sfmt = extract_format fmt start stop widths in
- match conv with
- | 'n' | 'N' ->
- sfmt.[String.length sfmt - 1] <- 'u';
- sfmt
- | _ -> sfmt
+ let sfmt = extract_format fmt start stop widths in
+ match conv with
+ | 'n' | 'N' ->
+ sfmt.[String.length sfmt - 1] <- 'u';
+ sfmt
+ | _ -> sfmt
;;
let extract_format_float conv fmt start stop widths =
- let sfmt = extract_format fmt start stop widths in
- match conv with
- | 'F' ->
- sfmt.[String.length sfmt - 1] <- 'g';
- sfmt
- | _ -> sfmt
+ let sfmt = extract_format fmt start stop widths in
+ match conv with
+ | 'F' ->
+ sfmt.[String.length sfmt - 1] <- 'g';
+ sfmt
+ | _ -> sfmt
;;
(* Returns the position of the next character following the meta format
ac
;;
-let count_arguments_of_format fmt =
+let count_printing_arguments_of_format fmt =
let ac = ac_of_format fmt in
(* For printing, only the regular arguments have to be counted. *)
ac.ac_rglr
loop 0 l
;;
-(* ``Abstracting'' version of kprintf: returns a (curried) function that
+(* 'Abstracting' version of kprintf: returns a (curried) function that
will print when totally applied.
Note: in the following, we are careful not to be badly caught
by the compiler optimizations for the representation of arrays. *)
let kapr kpr fmt =
- match count_arguments_of_format fmt with
+ match count_printing_arguments_of_format fmt with
| 0 -> kpr fmt [||]
| 1 -> Obj.magic (fun x ->
let a = Array.make 1 (Obj.repr 0) in
(* To scan an optional positional parameter specification,
i.e. an integer followed by a [$].
- Calling [got_spec] with appropriate arguments, we ``return'' a positional
+ Calling [got_spec] with appropriate arguments, we 'return' a positional
specification and an index to go on scanning the [fmt] format at hand.
Note that this is optimized for the regular case, i.e. no positional
- parameter, since in this case we juste ``return'' the constant
- [Spec_none]; in case we have a positional parameter, we ``return'' a
+ parameter, since in this case we juste 'return' the constant
+ [Spec_none]; in case we have a positional parameter, we 'return' a
[Spec_index] [positional_specification] which is a bit more costly.
Note also that we do not support [*$] specifications, since this would
lead to type checking problems: a [*$] positional specification means
- ``take the next argument to [printf] (which must be an integer value)'',
+ 'take the next argument to [printf] (which must be an integer value)',
name this integer value $n$; [*$] now designates parameter $n$.
Unfortunately, the type of a parameter specified via a [*$] positional
valid_float_loop 0 in
(fun sfmt x ->
- let s = format_float sfmt x in
match classify_float x with
- | FP_normal | FP_subnormal | FP_zero -> make_valid_float_lexeme s
- | FP_nan | FP_infinite -> s)
+ | FP_normal | FP_subnormal | FP_zero ->
+ make_valid_float_lexeme (format_float sfmt x)
+ | FP_infinite ->
+ if x < 0.0 then "neg_infinity" else "infinity"
+ | FP_nan ->
+ "nan")
;;
(* Decode a format string and act on it.
After consuming the appropriate number of arguments and formatting
them, one of the following five continuations described below is called:
- - [cont_s] for outputting a string (arguments: arg num, string, next pos)
- - [cont_a] for performing a %a action (arguments: arg num, fn, arg, next pos)
- - [cont_t] for performing a %t action (arguments: arg num, fn, next pos)
- - [cont_f] for performing a flush action (arguments: arg num, next pos)
- - [cont_m] for performing a %( action (arguments: arg num, sfmt, next pos)
+ - [cont_s] for outputting a string
+ (arguments: arg num, string, next pos)
+ - [cont_a] for performing a %a action
+ (arguments: arg num, fn, arg, next pos)
+ - [cont_t] for performing a %t action
+ (arguments: arg num, fn, next pos)
+ - [cont_f] for performing a flush action
+ (arguments: arg num, next pos)
+ - [cont_m] for performing a %( action
+ (arguments: arg num, sfmt, next pos)
"arg num" is the index in array [args] of the next argument to [printf].
"next pos" is the position in [fmt] of the first character following
| 'F' as conv ->
let (x : float) = get_arg spec n in
let s =
- if widths = [] then Pervasives.string_of_float x else
- format_float_lexeme (extract_format_float conv fmt pos i widths) x in
+ format_float_lexeme
+ (if widths = []
+ then "%.12g"
+ else extract_format_float conv fmt pos i widths)
+ x in
cont_s (next_index spec n) s (succ i)
| 'B' | 'b' ->
let (x : bool) = get_arg spec n in
| '{' | '(' as conv (* ')' '}' *) ->
let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
let i = succ i in
- let j = sub_format_for_printf conv fmt i in
+ let i = sub_format_for_printf conv fmt i in
if conv = '{' (* '}' *) then
(* Just print the format argument as a specification. *)
cont_s
(next_index spec n)
(summarize_format_type xf)
- j else
+ i else
(* Use the format argument instead of the format specification. *)
- cont_m (next_index spec n) xf j
+ cont_m (next_index spec n) xf i
| (* '(' *) ')' ->
cont_s n "" (succ i)
| conv ->
(* [out] is global to this definition of [pr], and must be shared by all its
recursive calls (if any). *)
let out = get_out fmt in
+ let outc c = outc out c in
+ let outs s = outs out s in
let rec pr k n fmt v =
if i >= len then Obj.magic (k out) else
match Sformat.unsafe_get fmt i with
| '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
- | c -> outc out c; doprn n (succ i)
+ | c -> outc c; doprn n (succ i)
+
and cont_s n s i =
- outs out s; doprn n i
+ outs s; doprn n i
and cont_a n printer arg i =
if to_s then
- outs out ((Obj.magic printer : unit -> _ -> string) () arg)
+ outs ((Obj.magic printer : unit -> _ -> string) () arg)
else
printer out arg;
doprn n i
and cont_t n printer i =
if to_s then
- outs out ((Obj.magic printer : unit -> string) ())
+ outs ((Obj.magic printer : unit -> string) ())
else
printer out;
doprn n i
and cont_f n i =
flush out; doprn n i
and cont_m n xf i =
- let m = Sformat.add_int_index (count_arguments_of_format xf) n in
+ let m =
+ Sformat.add_int_index
+ (count_printing_arguments_of_format xf) n in
pr (Obj.magic (fun _ -> doprn m i)) n xf v in
doprn n 0 in
kapr kpr fmt
;;
+(**************************************************************
+
+ Defining [fprintf] and various flavors of [fprintf].
+
+ **************************************************************)
+
let kfprintf k oc =
mkprintf false (fun _ -> oc) output_char output_string flush k
;;
-let ifprintf _ = kapr (fun _ -> Obj.magic ignore);;
+let ikfprintf k oc = kapr (fun _ _ -> Obj.magic (k oc));;
let fprintf oc = kfprintf ignore oc;;
+let ifprintf oc = ikfprintf ignore oc;;
let printf fmt = fprintf stdout fmt;;
let eprintf fmt = fprintf stderr fmt;;
let sprintf fmt = ksprintf (fun s -> s) fmt;;
-(* Obsolete and deprecated. *)
+(**************************************************************
+
+ Deprecated stuff.
+
+ **************************************************************)
+
let kprintf = ksprintf;;
(* For OCaml system internal use only: needed to implement modules [Format]
let ac_of_format = ac_of_format;;
+ let count_printing_arguments_of_format =
+ count_printing_arguments_of_format;;
+
let sub_format = sub_format;;
let summarize_format_type = summarize_format_type;;
(* *)
(***********************************************************************)
-(* $Id: printf.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Formatted output functions. *)
val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
- [s]: insert a string argument.
- [S]: convert a string argument to OCaml syntax (double quotes, escapes).
- [c]: insert a character argument.
- - [C]: convert a character argument to OCaml syntax (single quotes, escapes).
+ - [C]: convert a character argument to OCaml syntax
+ (single quotes, escapes).
- [f]: convert a floating-point argument to decimal notation,
in the style [dddd.ddd].
- [F]: convert a floating-point argument to OCaml syntax ([dddd.]
[fprintf] at the current point.
- [t]: same as [%a], but take only one argument (with type
[out_channel -> unit]) and apply it to [outchan].
- - [\{ fmt %\}]: convert a format string argument. The argument must
- have the same type as the internal format string [fmt].
+ - [\{ fmt %\}]: convert a format string argument to its type digest.
+ The argument must have the same type as the internal format string
+ [fmt].
- [( fmt %)]: format string substitution. Take a format string
argument and substitute it to the internal format string [fmt]
to print following arguments. The argument must have the same
- [!]: take no argument and flush the output.
- [%]: take no argument and output one [%] character.
- [\@]: take no argument and output one [\@] character.
- - [,]: take no argument and do nothing.
+ - [,]: take no argument and output nothing: a no-op delimiter for
+ conversion specifications.
The optional [flags] are:
- [-]: left-justify the output (default is right justification).
val eprintf : ('a, out_channel, unit) format -> 'a
(** Same as {!Printf.fprintf}, but output on [stderr]. *)
-val ifprintf : 'a -> ('b, 'a, unit) format -> 'b
-(** Same as {!Printf.fprintf}, but does not print anything.
- Useful to ignore some material when conditionally printing.
- @since 3.10.0
-*)
-
val sprintf : ('a, unit, string) format -> 'a
(** Same as {!Printf.fprintf}, but instead of printing on an output channel,
return a string containing the result of formatting the arguments. *)
append the formatted arguments to the given extensible buffer
(see module {!Buffer}). *)
+val ifprintf : 'a -> ('b, 'a, unit) format -> 'b
+(** Same as {!Printf.fprintf}, but does not print anything.
+ Useful to ignore some material when conditionally printing.
+ @since 3.10.0
+*)
+
(** Formatted output functions with continuations. *)
val kfprintf : (out_channel -> 'a) -> out_channel ->
@since 3.09.0
*)
+val ikfprintf : (out_channel -> 'a) -> out_channel ->
+ ('b, out_channel, unit, 'a) format4 -> 'b
+;;
+(** Same as [kfprintf] above, but does not print anything.
+ Useful to ignore some material when conditionally printing.
+ @since 4.0
+*)
+
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
(** Same as [sprintf] above, but instead of returning the string,
passes it to the first argument.
external unsafe_index_of_int : int -> index = "%identity";;
val succ_index : index -> index;;
+ val add_int_index : int -> index -> index;;
val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;;
val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;;
};;
val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;;
+ val count_printing_arguments_of_format :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int;;
val sub_format :
(('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) ->
(* *)
(* OCaml *)
(* *)
-(* François Pottier, projet Cristal, INRIA Rocquencourt *)
+(* Francois Pottier, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* *)
(***********************************************************************)
-(* $Id: queue.ml 12163 2012-02-18 09:36:13Z lefessan $ *)
-
exception Empty
(* OCaml currently does not allow the components of a sum type to be
next = tail'
} in
- let rec copy cell =
- if cell == tail then tail'
- else {
+ let rec copy prev cell =
+ if cell != tail
+ then let res = {
content = cell.content;
- next = copy cell.next
- } in
+ next = tail'
+ } in prev.next <- res;
+ copy res cell.next in
- tail'.next <- copy tail.next;
+ copy tail' tail.next;
{
length = q.length;
tail = tail'
(* *)
(***********************************************************************)
-(* $Id: queue.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** First-in first-out queues.
This module implements queues (FIFOs), with in-place modification.
+
+ {b Warning} This module is not thread-safe: each {!Queue.t} value
+ must be protected from concurrent access (e.g. with a {!Mutex.t}).
+ Failure to do so can lead to a crash.
*)
type 'a t
(* *)
(***********************************************************************)
-(* $Id: random.ml 12333 2012-04-10 15:08:10Z doligez $ *)
-
(* Pseudo-random number generator
This is a lagged-Fibonacci F(55, 24, +) with a modified addition
function to enhance the mixing of bits.
end;;
-(* This is the state you get with [init 27182818]. *)
+(* This is the state you get with [init 27182818] and then applying
+ the "land 0x3FFFFFFF" filter to them. See #5575, #5793, #5977. *)
let default = {
State.st = [|
- 0x7ae2522b; 0x5d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x7b086c47;
- 0x16d467d6; 0x501d91c7; 0x321df177; 0x4176c193; 0x1ff72bf1; 0x5e889109;
- 0x0b464b18; 0x6b86b97c; 0x4891da48; 0x03137463; 0x485ac5a1; 0x15d61f2f;
- 0x7bced359; 0x69c1c132; 0x7a86766e; 0x366d8c86; 0x1f5b6222; 0x7ce1b59f;
- 0x2ebf78e1; 0x67cd1b86; 0x658f3dc3; 0x789a8194; 0x42e4c44c; 0x58c43f7d;
- 0x0f6e534f; 0x1e7df359; 0x455d0b7e; 0x10e84e7e; 0x126198e4; 0x4e7722cb;
- 0x5cbede28; 0x7391b964; 0x7d40e92a; 0x4c59933d; 0x0b8cd0b7; 0x64efff1c;
- 0x2803fdaa; 0x08ebc72e; 0x4f522e32; 0x45398edc; 0x2144a04c; 0x4aef3cbd;
- 0x41ad4719; 0x75b93cd6; 0x2a559d4f; 0x5e6fd768; 0x66e27f36; 0x186f18c3;
+ 0x3ae2522b; 0x1d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x3b086c47;
+ 0x16d467d6; 0x101d91c7; 0x321df177; 0x0176c193; 0x1ff72bf1; 0x1e889109;
+ 0x0b464b18; 0x2b86b97c; 0x0891da48; 0x03137463; 0x085ac5a1; 0x15d61f2f;
+ 0x3bced359; 0x29c1c132; 0x3a86766e; 0x366d8c86; 0x1f5b6222; 0x3ce1b59f;
+ 0x2ebf78e1; 0x27cd1b86; 0x258f3dc3; 0x389a8194; 0x02e4c44c; 0x18c43f7d;
+ 0x0f6e534f; 0x1e7df359; 0x055d0b7e; 0x10e84e7e; 0x126198e4; 0x0e7722cb;
+ 0x1cbede28; 0x3391b964; 0x3d40e92a; 0x0c59933d; 0x0b8cd0b7; 0x24efff1c;
+ 0x2803fdaa; 0x08ebc72e; 0x0f522e32; 0x05398edc; 0x2144a04c; 0x0aef3cbd;
+ 0x01ad4719; 0x35b93cd6; 0x2a559d4f; 0x1e6fd768; 0x26e27f36; 0x186f18c3;
0x2fbf967a;
|];
State.idx = 0;
(* *)
(***********************************************************************)
-(* $Id: random.mli 12352 2012-04-13 12:43:24Z doligez $ *)
-
(** Pseudo-random number generators (PRNG). *)
(** {6 Basic functions} *)
(* *)
(***********************************************************************)
-(* $Id: scanf.ml 12506 2012-05-29 12:51:50Z frisch $ *)
-
(* The run-time library for scanners. *)
(* Scanning buffers. *)
We cannot prevent the scanning mechanism to use one lookahead character,
if needed by the semantics of the format string specifications (e.g. a
- trailing ``skip space'' specification in the format string); in this case,
+ trailing 'skip space' specification in the format string); in this case,
the mandatory lookahead character is indeed read from the input and not
used to return the token read. It is thus mandatory to be able to store
an unused lookahead character somewhere to get it as the first character
This phenomenon of reading mess is even worse when one defines more than
one scanning buffer reading from the same input channel
[ic]. Unfortunately, we have no simple way to get rid of this problem
- (unless the basic input channel API is modified to offer a ``consider this
- char as unread'' procedure to keep back the unused lookahead character as
+ (unless the basic input channel API is modified to offer a 'consider this
+ char as unread' procedure to keep back the unused lookahead character as
available in the input channel for further reading).
To prevent some of the confusion the scanning buffer allocation function
let from_ic_close_at_end = from_ic scan_close_at_end;;
(* The scanning buffer reading from [Pervasives.stdin].
- One could try to define [stdib] as a scanning buffer reading a character at a
- time (no bufferization at all), but unfortunately the top-level
- interaction would be wrong.
- This is due to some kind of ``race condition'' when reading from [Pervasives.stdin],
+ One could try to define [stdib] as a scanning buffer reading a character
+ at a time (no bufferization at all), but unfortunately the top-level
+ interaction would be wrong. This is due to some kind of
+ 'race condition' when reading from [Pervasives.stdin],
since the interactive compiler and [scanf] will simultaneously read the
- material they need from [Pervasives.stdin]; then, confusion will result from what should
- be read by the top-level and what should be read by [scanf].
+ material they need from [Pervasives.stdin]; then, confusion will result
+ from what should be read by the top-level and what should be read
+ by [scanf].
This is even more complicated by the one character lookahead that [scanf]
- is sometimes obliged to maintain: the lookahead character will be available
- for the next ([scanf]) entry, seemingly coming from nowhere.
+ is sometimes obliged to maintain: the lookahead character will be
+ available for the next ([scanf]) entry, seemingly coming from nowhere.
Also no [End_of_file] is raised when reading from stdin: if not enough
characters have been read, we simply ask to read more. *)
let stdin =
invalid_arg
(Printf.sprintf
"scanf: bad conversion %%%C, at char number %i \
- in format string ``%s''" c i (Sformat.to_string fmt))
+ in format string \'%s\'" c i (Sformat.to_string fmt))
;;
let incomplete_format fmt =
invalid_arg
- (Printf.sprintf "scanf: premature end of format string ``%s''"
+ (Printf.sprintf "scanf: premature end of format string \'%s\'"
(Sformat.to_string fmt))
;;
let format_mismatch_err fmt1 fmt2 =
Printf.sprintf
- "format read ``%s'' does not match specification ``%s''" fmt1 fmt2
+ "format read \'%s\' does not match specification \'%s\'" fmt1 fmt2
;;
let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);;
Tformat.summarize_format_type (string_to_format fmt2);;
(* Checking that [c] is indeed in the input, then skips it.
- In this case, the character c has been explicitly specified in the
+ In this case, the character [c] has been explicitly specified in the
format as being mandatory in the input; hence we should fail with
End_of_file in case of end_of_input. (Remember that Scan_failure is raised
only when (we can prove by evidence) that the input does not match the
format string given. We must thus differentiate End_of_file as an error
due to lack of input, and Scan_failure which is due to provably wrong
- input. I am not sure this is worth to burden: it is complex and somehow
+ input. I am not sure this is worth the burden: it is complex and somehow
subliminal; should be clearer to fail with Scan_failure "Not enough input
to complete scanning"!)
That's why, waiting for a better solution, we use checked_peek_char here.
- We are also careful to treat "\r\n" in the input as a end of line marker: it
- always matches a '\n' specification in the input format string. *)
+ We are also careful to treat "\r\n" in the input as an end of line marker:
+ it always matches a '\n' specification in the input format string. *)
let rec check_char ib c =
let ci = Scanning.checked_peek_char ib in
if ci = c then Scanning.invalidate_current_char ib else begin
bad_input (Printf.sprintf "character %C is not a decimal digit" c)
;;
-let scan_digits_plus digitp width ib =
+let scan_digits_plus basis digitp width ib =
(* To scan numbers from other bases, we use a predicate argument to
scan_digits. *)
let rec scan_digits width =
let width = Scanning.store_char width ib c in
scan_digits width
else
- bad_input (Printf.sprintf "character %C is not a digit" c)
+ bad_input (Printf.sprintf "character %C is not a valid %s digit" c basis)
;;
let is_binary_digit = function
| _ -> false
;;
-let scan_binary_int = scan_digits_plus is_binary_digit;;
+let scan_binary_int = scan_digits_plus "binary" is_binary_digit;;
let is_octal_digit = function
| '0' .. '7' -> true
| _ -> false
;;
-let scan_octal_int = scan_digits_plus is_octal_digit;;
+let scan_octal_int = scan_digits_plus "octal" is_octal_digit;;
let is_hexa_digit = function
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
| _ -> false
;;
-let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
+let scan_hexadecimal_int = scan_digits_plus "hexadecimal" is_hexa_digit;;
(* Scan a decimal integer. *)
let scan_unsigned_decimal_int = scan_decimal_digits_plus;;
and find_char width =
match check_next_char_for_char width ib with
- | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib)
- | c -> find_stop (Scanning.store_char width ib c)
+ | '\\' ->
+ find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib)
+ | c ->
+ find_stop (Scanning.store_char width ib c)
and find_stop width =
match check_next_char_for_char width ib with
let scanf_bad_input ib = function
| Scan_failure s | Failure s ->
let i = Scanning.char_count ib in
- bad_input (Printf.sprintf "scanf: bad input at char number %i: ``%s''" i s)
+ bad_input (Printf.sprintf "scanf: bad input at char number %i: \'%s\'" i s)
| x -> raise x
;;
if i > lim then incomplete_format fmt else
match Sformat.get fmt i with
| '0' .. '9' as conv ->
- let width, i = read_int_literal (decimal_value_of_char conv) (succ i) in
+ let width, i =
+ read_int_literal (decimal_value_of_char conv) (succ i) in
Some width, i
| _ -> None, i
| _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end
| '(' | '{' as conv (* ')' '}' *) ->
let i = succ i in
- (* Find the static specification for the format to read. *)
+ (* Find [mf], the static specification for the format to read. *)
let j =
Tformat.sub_format
incomplete_format bad_conversion conv fmt i in
let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in
- (* Read the specified format string in the input buffer,
- and check its correctness. *)
+ (* Read [rf], the specified format string in the input buffer,
+ and check its correctness w.r.t. [mf]. *)
let _x = scan_String width ib in
let rf = token_string ib in
if not (compatible_format_type rf mf) then format_mismatch rf mf else
+ (* Proceed according to the kind of metaformat found:
+ - %{ mf %} simply returns [rf] as the token read,
+ - %( mf %) returns [rf] as the first token read, then
+ returns a second token obtained by scanning the input with
+ format string [rf].
+ Behaviour for %( mf %) is mandatory for sake of format string
+ typechecking specification. To get pure format string
+ substitution behaviour, you should use %_( mf %) that skips the
+ first (format string) token and hence properly substitutes [mf] by
+ [rf] in the format string argument.
+ *)
(* For conversion %{%}, just return this format string as the token
- read. *)
+ read and go on with the rest of the format string argument. *)
if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else
- (* Or else, read according to the format string just read. *)
+ (* Or else, return this format string as the first token read;
+ then continue scanning using this format string to get
+ the following token read;
+ finally go on with the rest of the format string argument. *)
let ir, nf = scan (string_to_format rf) ir (stack f rf) 0 in
(* Return the format string read and the value just read,
then go on with the rest of the format. *)
let unescaped s =
sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
+;;
(*
Local Variables:
(* *)
(***********************************************************************)
-(* $Id: scanf.mli 12571 2012-06-05 18:21:50Z doligez $ *)
-
(** Formatted input functions. *)
(** {6 Introduction} *)
material with module {!Printf} or {!Format}),
- [f] is a function that has as many arguments as the number of values to
- read in the input. *)
+ read in the input.
+*)
(** {7 A simple example} *)
then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the
standard input and returns [f n] (that is [n + 1]). Thus, if we
evaluate [bscanf stdin "%d" f], and then enter [41] at the
- keyboard, we get [42] as the final result. *)
+ keyboard, we get [42] as the final result.
+*)
(** {7 Formatted input as a functional feature} *)
useful additions to easily define complex tokens; as expected within a
functional programming language, the formatted input functions also
support polymorphism, in particular arbitrary interaction with
- polymorphic user-defined scanners. Furthermore, the OCaml formatted input
- facility is fully type-checked at compile time. *)
+ polymorphic user-defined scanners. Furthermore, the OCaml formatted input
+ facility is fully type-checked at compile time.
+*)
(** {6 Formatted input channel} *)
input, and a token buffer to store the string matched so far.
Note: a scanning action may often require to examine one character in
- advance; when this ``lookahead'' character does not belong to the token
+ advance; when this 'lookahead' character does not belong to the token
read, it is stored back in the scanning buffer and becomes the next
- character yet to be read. *)
+ character yet to be read.
+*)
val stdin : in_channel;;
(** The standard input notion for the [Scanf] module.
val open_in : file_name -> in_channel;;
(** [Scanning.open_in fname] returns a formatted input channel for bufferized
- reading in text mode of file [fname].
+ reading in text mode from file [fname].
Note:
[open_in] returns a formatted input channel that efficiently reads
val open_in_bin : file_name -> in_channel;;
(** [Scanning.open_in_bin fname] returns a formatted input channel for
- bufferized reading in binary mode of file [fname].
+ bufferized reading in binary mode from file [fname].
@since 3.12.0
*)
(** [Scanning.from_string s] returns a formatted input channel which reads
from the given string.
Reading starts from the first character in the string.
- The end-of-input condition is set when the end of the string is reached. *)
+ The end-of-input condition is set when the end of the string is reached.
+*)
val from_function : (unit -> char) -> in_channel;;
(** [Scanning.from_function f] returns a formatted input channel with the
When scanning needs one more character, the given function is called.
When the function has no more character to provide, it {e must} signal an
- end-of-input condition by raising the exception [End_of_file]. *)
+ end-of-input condition by raising the exception [End_of_file].
+*)
val from_channel : Pervasives.in_channel -> in_channel;;
(** [Scanning.from_channel ic] returns a formatted input channel which reads
from the regular input channel [ic] argument, starting at the current
- reading position. *)
+ reading position.
+*)
val end_of_input : in_channel -> bool;;
(** [Scanning.end_of_input ic] tests the end-of-input condition of the given
- formatted input channel. *)
+ formatted input channel.
+*)
val beginning_of_input : in_channel -> bool;;
(** [Scanning.beginning_of_input ic] tests the beginning of input condition of
- the given formatted input channel. *)
+ the given formatted input channel.
+*)
val name_of_input : in_channel -> string;;
(** [Scanning.name_of_input ic] returns the name of the character source
val stdib : in_channel;;
(** A deprecated alias for [Scanning.stdin], the scanning buffer reading from
- [Pervasives.stdin]. *)
+ [Pervasives.stdin].
+*)
end;;
*)
exception Scan_failure of string;;
-(** The exception that formatted input functions raise when the input cannot be
- read according to the given format. *)
+(** The exception that formatted input functions raise when the input cannot
+ be read according to the given format.
+*)
(** {6 The general formatted input function} *)
[Scanf.sscanf "x= 1" "%s = %i" f] returns [2].
Arguments [r1] to [rN] are user-defined input functions that read the
- argument corresponding to a [%r] conversion. *)
+ argument corresponding to the [%r] conversions specified in the format
+ string.
+*)
(** {6 Format string description} *)
-(** The format is a character string which contains three types of
+(** The format string is a character string which contains three types of
objects:
- plain characters, which are simply matched with the characters of the
input (with a special case for space and line feed, see {!Scanf.space}),
- conversion specifications, each of which causes reading and conversion of
one argument for the function [f] (see {!Scanf.conversion}),
- scanning indications to specify boundaries of tokens
- (see scanning {!Scanf.indication}). *)
+ (see scanning {!Scanf.indication}).
+*)
(** {7:space The space character in format strings} *)
special exceptions to this rule: the space character ([' '] or ASCII code
32) and the line feed character (['\n'] or ASCII code 10).
A space does not match a single space character, but any amount of
- ``whitespace'' in the input. More precisely, a space inside the format
+ 'whitespace' in the input. More precisely, a space inside the format
string matches {e any number} of tab, space, line feed and carriage
return characters. Similarly, a line feed character in the format string
matches either a single line feed or a carriage return followed by a line
also matches no amount of whitespace at all; hence, the call [bscanf ib
"Price = %d $" (fun p -> p)] succeeds and returns [1] when reading an
input with various whitespace in it, such as [Price = 1 $],
- [Price = 1 $], or even [Price=1$]. *)
+ [Price = 1 $], or even [Price=1$].
+*)
(** {7:conversion Conversion specifications in format strings} *)
function and applies it to the scanning buffer [ib] to read the
next argument. The input function [ri] must therefore have type
[Scanning.in_channel -> 'a] and the argument read has type ['a].
- - [\{ fmt %\}]: reads a format string argument. The format string
+ - [\{ fmt %\}]: reads a format string argument. The format string
read must have the same type as the format string specification
- [fmt]. For instance, ["%{ %i %}"] reads any format string that
+ [fmt]. For instance, ["%{ %i %}"] reads any format string that
can read a value of type [int]; hence, if [s] is the string
["fmt:\"number is %u\""], then [Scanf.sscanf s "fmt: %{%i%}"]
succeeds and returns the format string ["number is %u"].
- - [\( fmt %\)]: scanning format substitution.
- Reads a format string and then goes on scanning with the format string
- read, instead of using [fmt].
- The format string read must have the same type as the format string
+ - [\( fmt %\)]: scanning sub-format substitution.
+ Reads a format string [rf] in the input, then goes on scanning with
+ [rf] instead of scanning with [fmt].
+ The format string [rf] must have the same type as the format string
specification [fmt] that it replaces.
For instance, ["%( %i %)"] reads any format string that can read a value
of type [int].
- Returns the format string read, and the value read using the format
- string read.
+ The conversion returns the format string read [rf], and then a value
+ read using [rf].
Hence, if [s] is the string ["\"%4d\"1234.00"], then
[Scanf.sscanf s "%(%i%)" (fun fmt i -> fmt, i)] evaluates to
[("%4d", 1234)].
- If the special flag [_] is used, the conversion discards the
- format string read and only returns the value read with the format
- string read.
- Hence, if [s] is the string ["\"%4d\"1234.00"], then
- [Scanf.sscanf s "%_(%i%)"] is simply equivalent to
- [Scanf.sscanf "1234.00" "%4d"].
+
+ This behaviour is not mere format substitution, since the conversion
+ returns the format string read as additional argument. If you need
+ pure format substitution, use special flag [_] to discard the
+ extraneous argument: conversion [%_\( fmt %\)] reads a format string
+ [rf] and then behaves the same as format string [rf]. Hence, if [s] is
+ the string ["\"%4d\"1234.00"], then [Scanf.sscanf s "%_(%i%)"] is
+ simply equivalent to [Scanf.sscanf "1234.00" "%4d"].
+
- [l]: returns the number of lines read so far.
- [n]: returns the number of characters read so far.
- [N] or [L]: returns the number of tokens read so far.
analysis and parsing. If it appears not expressive enough for your
needs, several alternative exists: regular expressions (module
[Str]), stream parsers, [ocamllex]-generated lexers,
- [ocamlyacc]-generated parsers. *)
+ [ocamlyacc]-generated parsers.
+*)
(** {7:indication Scanning indications in format strings} *)
Note:
- - As usual in format strings, [%] characters must be escaped using [%%]
- and [%\@] is equivalent to [\@]; this rule still holds within range
- specifications and scanning indications.
- For instance, ["%s@%%"] reads a string up to the next [%] character.
+ - As usual in format strings, [%] and [\@] characters must be escaped
+ using [%%] and [%\@]; this rule still holds within range specifications
+ and scanning indications.
+ For instance, ["%s@%%"] reads a string up to the next [%] character.
- The scanning indications introduce slight differences in the syntax of
[Scanf] format strings, compared to those used for the [Printf]
module. However, the scanning indications are similar to those used in
by [!Scanf.bscanf], it is wise to use printing functions from the
[Format] module (or, if you need to use functions from [Printf], banish
or carefully double check the format strings that contain ['\@']
- characters). *)
+ characters).
+*)
(** {7 Exceptions during scanning} *)
- as a consequence, scanning a [%s] conversion never raises exception
[End_of_file]: if the end of input is reached the conversion succeeds and
simply returns the characters read so far, or [""] if none were ever read.
- *)
+*)
(** {6 Specialised formatted input functions} *)
position, and so on).
As a consequence, never mix direct low level reading and high level
- scanning from the same regular input channel. *)
+ scanning from the same regular input channel.
+*)
val sscanf : string -> ('a, 'b, 'c, 'd) scanner;;
(** Same as {!Scanf.bscanf}, but reads from the given string. *)
val scanf : ('a, 'b, 'c, 'd) scanner;;
(** Same as {!Scanf.bscanf}, but reads from the predefined formatted input
- channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin]. *)
+ channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin].
+*)
val kscanf :
Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) ->
[ef] that is called in case of error: if the scanning process or
some conversion fails, the scanning function aborts and calls the
error handling function [ef] with the formatted input channel and the
- exception that aborted the scanning process as arguments. *)
+ exception that aborted the scanning process as arguments.
+*)
(** {6 Reading format strings from input} *)
@since 3.10.0
*)
-val unescaped : string -> string
+val unescaped : string -> string;;
(** Return a copy of the argument with escape sequences, following the
lexical conventions of OCaml, replaced by their corresponding
- special characters. If there is no escape sequence in the
+ special characters. If there is no escape sequence in the
argument, still return a copy, contrary to String.escaped.
@since 4.00.0
*)
(* *)
(***********************************************************************)
-(* $Id: set.ml 12510 2012-05-30 11:28:51Z scherer $ *)
-
(* Sets over ordered types *)
module type OrderedType =
val max_elt: t -> elt
val choose: t -> elt
val split: elt -> t -> t * bool * t
+ val find: elt -> t -> elt
end
module Make(Ord: OrderedType) =
let choose = min_elt
+ let rec find x = function
+ Empty -> raise Not_found
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then v
+ else find x (if c < 0 then l else r)
end
(* *)
(***********************************************************************)
-(* $Id: set.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Sets over ordered types.
This module implements the set data structure, given a total ordering
val inter: t -> t -> t
(** Set intersection. *)
- (** Set difference. *)
val diff: t -> t -> t
+ (** Set difference. *)
val compare: t -> t -> int
(** Total ordering between sets. Can be used as the ordering function
strictly greater than [x];
[present] is [false] if [s] contains no element equal to [x],
or [true] if [s] contains an element equal to [x]. *)
+
+ val find: elt -> t -> elt
+ (** [find x s] returns the element of [s] equal to [x] (according
+ to [Ord.compare]), or raise [Not_found] if no such element
+ exists.
+ @since 4.01.0 *)
end
(** Output signature of the functor {!Set.Make}. *)
(* *)
(***********************************************************************)
-(* $Id: sort.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Merging and sorting *)
open Array
(* *)
(***********************************************************************)
-(* $Id: sort.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Sorting and merging lists.
@deprecated This module is obsolete and exists only for backward
(* *)
(***********************************************************************)
-(* $Id: stack.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type 'a t = { mutable c : 'a list }
exception Empty
(* *)
(***********************************************************************)
-(* $Id: stack.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Last-in first-out stacks.
This module implements stacks (LIFOs), with in-place modification.
(* *)
(***********************************************************************)
-(* $Id: stdLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [StdLabels]: meta-module for labelled libraries *)
module Array = ArrayLabels
(* *)
(***********************************************************************)
-(* $Id: stdLabels.mli 12823 2012-08-06 11:41:12Z doligez $ *)
-
(** Standard labeled libraries.
This meta-module provides labelized version of the {!Array},
(* *)
(***********************************************************************)
-(* $Id: std_exit.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Ensure that [at_exit] functions are called at the end of every program *)
let _ = do_at_exit()
# This file lists all standard library modules
# (in the same order as Makefile.shared).
# It is used in particular to know what to expunge in toplevels.
-# $Id: stdlib.mllib 9540 2010-01-20 16:26:46Z doligez $
Pervasives
Array
(* *)
(***********************************************************************)
-(* $Id: stream.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* The fields of type t are not mutable to preserve polymorphism of
the empty stream. This is type safe because the empty stream is never
patched. *)
and 'a data =
Sempty
| Scons of 'a * 'a data
- | Sapp of 'a data * 'a t
- | Slazy of 'a t Lazy.t
+ | Sapp of 'a data * 'a data
+ | Slazy of 'a data Lazy.t
| Sgen of 'a gen
| Sbuffio of buffio
and 'a gen = { mutable curr : 'a option option; func : int -> 'a option }
b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0
;;
-let rec get_data s d = match d with
- (* Only return a "forced stream", that is either Sempty or
- Scons(a,_). If d is a generator or a buffer, the item a is seen as
- extracted from the generator/buffer.
-
- Forcing also updates the "count" field of the delayed stream,
- in the Sapp and Slazy cases (see slazy/lapp implementation below). *)
+let rec get_data count d = match d with
+ (* Returns either Sempty or Scons(a, _) even when d is a generator
+ or a buffer. In those cases, the item a is seen as extracted from
+ the generator/buffer.
+ The count parameter is used for calling `Sgen-functions'. *)
Sempty | Scons (_, _) -> d
- | Sapp (d1, s2) ->
- begin match get_data s d1 with
- Scons (a, d11) -> Scons (a, Sapp (d11, s2))
- | Sempty ->
- set_count s s2.count;
- get_data s s2.data
+ | Sapp (d1, d2) ->
+ begin match get_data count d1 with
+ Scons (a, d11) -> Scons (a, Sapp (d11, d2))
+ | Sempty -> get_data count d2
| _ -> assert false
end
- | Sgen {curr = Some None; _ } -> Sempty
- | Sgen ({curr = Some(Some a); _ } as g) ->
+ | Sgen {curr = Some None; func = _ } -> Sempty
+ | Sgen ({curr = Some(Some a); func = f} as g) ->
g.curr <- None; Scons(a, d)
- | Sgen ({curr = None; _} as g) ->
- (* Warning: anyone using g thinks that an item has been read *)
- begin match g.func s.count with
+ | Sgen g ->
+ begin match g.func count with
None -> g.curr <- Some(None); Sempty
- | Some a ->
- (* One must not update g.curr here, because there Scons(a,d)
- result of get_data, if the outer stream s was a Sapp, will
- be used to update the outer stream to Scons(a,s): there is
- already a memoization process at the outer layer. If g.curr
- was updated here, the saved element would be produced twice,
- once by the outer layer, once by Sgen/g.curr. *)
- Scons(a, d)
+ | Some a -> Scons(a, d)
+ (* Warning: anyone using g thinks that an item has been read *)
end
| Sbuffio b ->
if b.ind >= b.len then fill_buff b;
let r = Obj.magic (String.unsafe_get b.buff b.ind) in
(* Warning: anyone using g thinks that an item has been read *)
b.ind <- succ b.ind; Scons(r, d)
- | Slazy f ->
- let s2 = Lazy.force f in
- set_count s s2.count;
- get_data s s2.data
+ | Slazy f -> get_data count (Lazy.force f)
;;
let rec peek s =
Sempty -> None
| Scons (a, _) -> Some a
| Sapp (_, _) ->
- begin match get_data s s.data with
- | Scons(a, _) as d -> set_data s d; Some a
+ begin match get_data s.count s.data with
+ Scons(a, _) as d -> set_data s d; Some a
| Sempty -> None
| _ -> assert false
end
- | Slazy f ->
- let s2 = Lazy.force f in
- set_count s s2.count;
- set_data s s2.data;
- peek s
- | Sgen {curr = Some a; _ } -> a
- | Sgen ({curr = None; _ } as g) ->
- let x = g.func s.count in
- g.curr <- Some x; x
+ | Slazy f -> set_data s (Lazy.force f); peek s
+ | Sgen {curr = Some a} -> a
+ | Sgen g -> let x = g.func s.count in g.curr <- Some x; x
| Sbuffio b ->
if b.ind >= b.len then fill_buff b;
if b.len == 0 then begin set_data s Sempty; None end
;;
let of_string s =
- from (fun c -> if c < String.length s then Some s.[c] else None)
+ let count = ref 0 in
+ from (fun _ ->
+ (* We cannot use the index passed by the [from] function directly
+ because it returns the current stream count, with absolutely no
+ guarantee that it will start from 0. For example, in the case
+ of [Stream.icons 'c' (Stream.from_string "ab")], the first
+ access to the string will be made with count [1] already.
+ *)
+ let c = !count in
+ if c < String.length s
+ then (incr count; Some s.[c])
+ else None)
;;
let of_channel ic =
(* Stream expressions builders *)
-(* In the slazy and lapp case, we can't statically predict the value
- of the "count" field. We put a dummy 0 value, which will be updated
- when the parameter stream is forced (see update code in [get_data]
- and [peek]). *)
-
+let iapp i s = {count = 0; data = Sapp (i.data, s.data)};;
+let icons i s = {count = 0; data = Scons (i, s.data)};;
let ising i = {count = 0; data = Scons (i, Sempty)};;
-let icons i s = {count = s.count - 1; data = Scons (i, s.data)};;
-let iapp i s = {count = i.count; data = Sapp (i.data, s)};;
-let sempty = {count = 0; data = Sempty};;
-let slazy f = {count = 0; data = Slazy (lazy (f()))};;
+let lapp f s =
+ {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))}
+;;
+let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};;
+let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};;
-let lsing f = {count = 0; data = Slazy (lazy (ising (f())))};;
-let lcons f s = {count = 0; data = Slazy (lazy (icons (f()) s))};;
-let lapp f s = {count = 0; data = Slazy (lazy(iapp (f()) s))};;
+let sempty = {count = 0; data = Sempty};;
+let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};;
(* For debugging use *)
print_string ", ";
dump_data f d;
print_string ")"
- | Sapp (d1, s2) ->
+ | Sapp (d1, d2) ->
print_string "Sapp (";
dump_data f d1;
print_string ", ";
- dump f s2;
+ dump_data f d2;
print_string ")"
| Slazy _ -> print_string "Slazy"
| Sgen _ -> print_string "Sgen"
(* *)
(***********************************************************************)
-(* $Id: stream.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** Streams and parsers. *)
type 'a t
To create a new stream element, the function [f] is called with
the current stream count. The user function [f] must return either
[Some <value>] for a value or [None] to specify the end of the
- stream. *)
+ stream.
+
+ Do note that the indices passed to [f] may not start at [0] in the
+ general case. For example, [[< '0; '1; Stream.from f >]] would call
+ [f] the first time with count [2].
+*)
val of_list : 'a list -> 'a t
(** Return the stream holding the elements of the list in the same
(* *)
(***********************************************************************)
-(* $Id: string.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
(* String operations *)
external length : string -> int = "%string_length"
(* *)
(***********************************************************************)
-(* $Id: string.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** String operations.
Given a string [s] of length [l], we call character number in [s]
(* *)
(***********************************************************************)
-(* $Id: stringLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Module [StringLabels]: labelled String module *)
include String
(* *)
(***********************************************************************)
-(* $Id: stringLabels.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
(** String operations. *)
external length : string -> int = "%string_length"
(* *)
(***********************************************************************)
-(* $Id: sys.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
(** System interface. *)
val argv : string array
- ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
- ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
+val unix : bool
+(** True if [Sys.os_type = "Unix"].
+ @since 4.01.0 *)
+
+val win32 : bool
+(** True if [Sys.os_type = "Win32"].
+ @since 4.01.0 *)
+
+val cygwin : bool
+(** True if [Sys.os_type = "Cygwin"].
+ @since 4.01.0 *)
+
val word_size : int
(** Size of one word on the machine currently executing the OCaml
program, in bits: 32 or 64. *)
type signal_behavior =
Signal_default
| Signal_ignore
- | Signal_handle of (int -> unit)
+ | Signal_handle of (int -> unit) (** *)
(** What to do when receiving a signal:
- [Signal_default]: take the default behavior
(usually: abort the program)
(* *)
(***********************************************************************)
-(* $Id: sys.mlp 12210 2012-03-08 19:52:03Z doligez $ *)
-
(* WARNING: sys.ml is generated from sys.mlp. DO NOT EDIT sys.ml or
your changes will be lost.
*)
external get_config: unit -> string * int * bool = "caml_sys_get_config"
external get_argv: unit -> string * string array = "caml_sys_get_argv"
+external big_endian : unit -> bool = "%big_endian"
+external word_size : unit -> int = "%word_size"
+external unix : unit -> bool = "%ostype_unix"
+external win32 : unit -> bool = "%ostype_win32"
+external cygwin : unit -> bool = "%ostype_cygwin"
let (executable_name, argv) = get_argv()
-let (os_type, word_size, big_endian) = get_config()
+let (os_type, _, _) = get_config()
+let big_endian = big_endian ()
+let word_size = word_size ()
+let unix = unix ()
+let win32 = win32 ()
+let cygwin = cygwin ()
let max_array_length = (1 lsl (word_size - 10)) - 1;;
let max_string_length = word_size / 8 * max_array_length - 1;;
(* *)
(***********************************************************************)
-(* $Id: weak.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Weak array operations *)
type 'a t;;
t.hashes.(index) <- newhashes;
if sz <= t.limit && newsz > t.limit then begin
t.oversize <- t.oversize + 1;
- for i = 0 to over_limit do test_shrink_bucket t done;
+ for _i = 0 to over_limit do test_shrink_bucket t done;
end;
if t.oversize > Array.length t.table / over_limit then resize t;
end else if check bucket i then begin
(* *)
(***********************************************************************)
-(* $Id: weak.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Arrays of weak pointers and hash tables of weak pointers. *)
-# $Id: Makefile 12579 2012-06-06 15:46:37Z doligez $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
BASEDIR=${PWD}
-NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-print-directory' || echo ''`
+NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 && echo '--no-print-directory'`
+FIND=find
+include ../config/Makefile
+
+.PHONY: default
default:
@echo "Available targets:"
- @echo " all launches all tests"
- @echo " list FILE=f launches the tests referenced in file f (one path per line)"
- @echo " one DIR=p launches the tests located in path p"
- @echo " promote DIR=p promotes the reference files for the tests located in path p"
- @echo " lib builds library modules"
- @echo " clean deletes generated files"
- @echo " report prints the report for the last execution, if any"
+ @echo " all launch all tests"
+ @echo " list FILE=f launch the tests referenced in file f (one path per line)"
+ @echo " one DIR=p launch the tests located in path p"
+ @echo " promote DIR=p promote the reference files for the tests located in path p"
+ @echo " lib build library modules"
+ @echo " clean delete generated files"
+ @echo " report print the report for the last execution, if any"
+.PHONY: all
all: lib
@for dir in tests/*; do \
$(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
done 2>&1 | tee _log
@$(MAKE) report
+.PHONY: list
list: lib
- @if [ -z $(FILE) ]; then echo "No value set for variable 'FILE'."; exit 1; fi
- @if [ ! -f $(FILE) ]; then echo "File '$(FILE)' does not exist."; exit 1; fi
+ @if [ -z "$(FILE)" ]; \
+ then echo "No value set for variable 'FILE'."; \
+ exit 1; \
+ fi
@while read LINE; do \
$(MAKE) $(NO_PRINT) exec-one DIR=$$LINE; \
- done < $(FILE) 2>&1 | tee _log
+ done <$(FILE) 2>&1 | tee _log
@$(MAKE) report
+.PHONY: one
one: lib
- @if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi
- @if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi
+ @if [ -z "$(DIR)" ]; then \
+ echo "No value set for variable 'DIR'."; \
+ exit 1; \
+ fi
+ @if [ ! -d $(DIR) ]; then \
+ echo "Directory '$(DIR)' does not exist."; \
+ exit 1; \
+ fi
@$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR)
+.PHONY: exec-one
exec-one:
@if [ ! -f $(DIR)/Makefile ]; then \
for dir in $(DIR)/*; do \
$(MAKE) exec-one DIR=$$dir; \
fi; \
done; \
- else \
+ else \
echo "Running tests from '$$DIR' ..."; \
- (cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR)); \
+ cd $(DIR) && \
+ $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) || echo '=> unexpected error'; \
fi
-promote: FORCE
- @if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi
- @if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi
- @(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote)
+.PHONY: promote
+promote:
+ @if [ -z "$(DIR)" ]; then \
+ echo "No value set for variable 'DIR'."; \
+ exit 1; \
+ fi
+ @if [ ! -d $(DIR) ]; then \
+ echo "Directory '$(DIR)' does not exist."; \
+ exit 1; \
+ fi
+ @cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote
-lib: FORCE
- @(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR))
+.PHONY: lib
+lib:
+ @cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)
-clean: FORCE
- @(cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean)
- @for file in `find interactive tests -name Makefile`; do \
+.PHONY: clean
+clean:
+ @cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean
+ @for file in `$(FIND) interactive tests -name Makefile`; do \
(cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
done
-report: FORCE
+.PHONY: report
+report:
@if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi
- @echo ''
- @echo 'Summary:'
- @echo ' ' `grep 'passed$$' _log | wc -l` 'test(s) passed'
- @echo ' ' `grep 'failed$$' _log | wc -l` 'test(s) failed'
- @echo ' ' `grep '^Error' _log | wc -l` 'compilation error(s)'
- @echo ' ' `grep '^Warning' _log | wc -l` 'compilation warning(s)'
- @echo ' ' `grep '^make\[2\]: ' _log | wc -l` 'makefile error(s)'
-
-empty: FORCE
+ @awk -f makefiles/summarize.awk <_log
-FORCE:
+.PHONY: empty
+empty:
--- /dev/null
+*.tar.gz
+*.tar.bz2
+*.tgz
+*.tbz
+*.zip
+
+log-*
+log_*
+
+advi
+advi-1.10.2
+altergo
+alt-ergo-0.95
+binprot
+bin_prot-109.30.00
+bitstring
+ocaml-bitstring-2.0.3
+boomerang
+boomerang-0.2
+calendar
+calendar-2.03.2
+camlimages
+camlimages-4.0.1
+camlpdf
+camlpdf-0.5
+camlp5
+camlp5-6.10
+camlzip
+camlzip-1.04
+camomile
+camomile-0.8.4
+comparelib
+comparelib-109.15.00
+compcert
+compcert-1.13
+configfile
+config-file-1.1
+coq
+coq-8.4pl1
+core
+core-109.37.00
+coreextended
+core_extended-109.36.00
+corekernel
+core_kernel-109.37.00
+cryptokit
+cryptokit-1.6
+customprintf
+custom_printf-109.27.00
+dbm
+camldbm-1.0
+expect
+ocaml-expect-0.0.3
+extlib
+extlib-1.5.2
+fieldslib
+fieldslib-109.15.00
+fileutils
+ocaml-fileutils-0.4.4
+findlib
+findlib-1.3.3
+framac
+frama-c-Oxygen-20120901
+geneweb
+gw-6.05-src
+herelib
+herelib-109.35.00
+hevea
+hevea-2.09
+kaputt
+kaputt-1.2
+lablgtk
+lablgtk-2.16.0
+lablgtkextras
+lablgtkextras-1.3
+lwt
+lwt-2.4.0
+menhir
+menhir-20120123
+mldonkey
+mldonkey-3.1.2
+mysql
+ocaml-mysql-1.0.4
+oasis
+oasis-0.3.0
+obrowser
+obrowser-1.1.1
+ocamlgraph
+ocamlgraph-1.8.2
+ocamlify
+ocamlify-0.0.1
+ocamlmod
+ocamlmod-0.0.3
+ocamlnet
+ocamlnet-3.5.1
+ocamlscript
+ocamlscript-2.0.3
+ocamlssl
+ocaml-ssl-0.4.6
+ocamltext
+ocaml-text-0.5
+ocgi
+ocgi-0.5
+ocsigen
+ocsigen-bundle-2.2.2
+odn
+ocaml-data-notation-0.0.10
+omake
+omake-0.9.8.6
+ounit
+ounit-1.1.2
+paounit
+pa_ounit-109.36.00
+pcre
+pcre-ocaml-6.2.5
+pipebang
+pipebang-109.28.00
+react
+react-0.9.3
+res
+res-3.2.0
+rss
+ocamlrss-2.2.2
+sexplib
+sexplib-109.15.00
+sks
+sks-1.1.3
+sqlite
+sqlite3-ocaml-2.0.1
+textutils
+textutils-109.36.00
+typeconv
+type_conv-109.28.00
+unison
+unison-2.45.4
+variantslib
+variantslib-109.15.00
+vsyml
+vsyml-2010-04-06
+xmllight
+xml-light-2.2
+xmlm
+xmlm-1.1.0
+zen
+zen_2.3.2
+._ZEN_2.3.2
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2012 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+# To use this test set, you need OCaml installed in a directory where
+# you have write rights.
+
+# Warning: use of this Makefile will install lots of software
+# in the same place where OCaml is installed.
+
+# It is recommended that you install OCaml in some isolated
+# directory D (for example /usr/local/ocaml/test), add D/bin
+# at the front of your PATH, then use this Makefile to test
+# your OCaml installation.
+
+WGET = wget --no-check-certificate --progress=dot:mega
+
+PREFIX = "`ocamlc -where | sed -e 's|/[^/]*/[^/]*$$||'`"
+VERSION = `ocamlc -vnum`
+
+.PHONY: default
+default:
+ @printf "\n\n########## Starting make at " >>log-${VERSION}
+ @date >>log-${VERSION}
+ ${MAKE} platform >>log-${VERSION} 2>&1
+ @printf '\n'
+ mv log-${VERSION} log_${VERSION}_`date -u '+%Y-%m-%d:%H:%M:%S'`
+
+# Platform-dependent subsets: add your own here.
+
+.PHONY: all-cygwin
+all-cygwin: findlib ounit res pcre react ocamltext ocamlssl camlzip cryptokit \
+ sqlite ocgi xmllight configfile xmlm omake \
+ camomile zen vsyml extlib fileutils ocamlify ocamlmod \
+ calendar dbm ocamlscript camlp5 geneweb coq
+
+all-macos: findlib lablgtk ocamlgraph ounit res pcre core react ocamltext \
+ ocamlssl lwt camlzip cryptokit sqlite menhir obrowser hevea \
+ unison ocgi xmllight configfile xmlm lablgtkextras sks omake \
+ altergo boomerang camomile zen vsyml ocamlnet extlib fileutils \
+ odn ocamlify expect ocamlmod oasis calendar camlimages advi \
+ dbm ocsigen ocamlscript camlp5 geneweb coq framac
+
+platform:
+ case `uname -s` in \
+ CYGWIN*) ${MAKE} all-cygwin;; \
+ Darwin) ${MAKE} all-macos;; \
+ *) ${MAKE} all;; \
+ esac
+
+# http://projects.camlcity.org/projects/findlib.html
+FINDLIB=findlib-1.3.3
+${FINDLIB}.tar.gz:
+ ${WGET} http://download.camlcity.org/download/$@
+findlib: ${FINDLIB}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${FINDLIB}
+ tar zxf ${FINDLIB}.tar.gz
+ ./Patcher.sh ${FINDLIB}
+ ( cd ${FINDLIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure && \
+ ${MAKE} all && \
+ ${MAKE} opt && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${FINDLIB} findlib
+distclean::
+ rm -f ${FINDLIB}.tar.gz
+all: findlib
+
+# http://lablgtk.forge.ocamlcore.org/
+LABLGTK=lablgtk-2.16.0
+${LABLGTK}.tar.gz:
+ ${WGET} https://forge.ocamlcore.org/frs/download.php/561/$@
+lablgtk: ${LABLGTK}.tar.gz findlib # TODO: add lablgl
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${LABLGTK}
+ tar zxf ${LABLGTK}.tar.gz
+ ./Patcher.sh ${LABLGTK}
+ ( cd ${LABLGTK} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure -prefix ${PREFIX} && \
+ ${MAKE} world && \
+ ocamlfind remove lablgtk2 && \
+ ${MAKE} install && \
+ rm -f ${PREFIX}/lib/ocaml/lablgtk2 && \
+ ln -f -s ${PREFIX}/lib/ocaml/site-lib/lablgtk2 \
+ ${PREFIX}/lib/ocaml/lablgtk2 )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${LABLGTK} lablgtk
+distclean::
+ rm -f ${LABLGTK}.tar.gz
+all: lablgtk
+
+# http://ocamlgraph.lri.fr/
+OCAMLGRAPH=ocamlgraph-1.8.2
+${OCAMLGRAPH}.tar.gz:
+ ${WGET} http://ocamlgraph.lri.fr/download/$@
+ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib lablgtk
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLGRAPH}
+ tar zxf ${OCAMLGRAPH}.tar.gz
+ ./Patcher.sh ${OCAMLGRAPH}
+ ( cd ${OCAMLGRAPH} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure -prefix ${PREFIX} && \
+ ${MAKE} && \
+ rm -rf ${PREFIX}/lib/ocaml/ocamlgraph && \
+ ocamlfind remove ocamlgraph && \
+ ${MAKE} install install-findlib && \
+ ln -s ${PREFIX}/lib/ocaml/site-lib/ocamlgraph \
+ ${PREFIX}/lib/ocaml/ocamlgraph )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLGRAPH} ocamlgraph
+distclean::
+ rm -f ${OCAMLGRAPH}.tar.gz
+all: ocamlgraph
+
+# http://ounit.forge.ocamlcore.org/
+OUNIT=ounit-1.1.2
+${OUNIT}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/886/$@
+ounit: ${OUNIT}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OUNIT}
+ tar zxf ${OUNIT}.tar.gz
+ ./Patcher.sh ${OUNIT}
+ ( cd ${OUNIT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} && \
+ ocamlfind remove oUnit && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OUNIT} ounit
+distclean::
+ rm -f ${OUNIT}.tar.gz
+all: ounit
+
+# https://bitbucket.org/mmottl/res
+RES=res-3.2.0
+${RES}.tar.gz:
+ ${WGET} https://bitbucket.org/mmottl/res/downloads/$@
+res: ${RES}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${RES}
+ tar zxf ${RES}.tar.gz
+ ./Patcher.sh ${RES}
+ ( cd ${RES} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} && \
+ ocamlfind remove res && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${RES} res
+distclean::
+ rm -f ${RES}.tar.gz
+all: res
+
+# https://bitbucket.org/mmottl/pcre-ocaml
+PCRE=pcre-ocaml-6.2.5
+${PCRE}.tar.gz:
+ ${WGET} https://bitbucket.org/mmottl/pcre-ocaml/downloads/$@
+pcre: ${PCRE}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${PCRE}
+ tar zxf ${PCRE}.tar.gz
+ ./Patcher.sh ${PCRE}
+ ( cd ${PCRE} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} && \
+ ocamlfind remove pcre && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${PCRE} pcre
+distclean::
+ rm -f ${PCRE}.tar.gz
+all: pcre
+
+###########################################################################
+
+## Jane Street Core
+
+# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/
+TYPECONV=type_conv-109.28.00
+${TYPECONV}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@
+typeconv: ${TYPECONV}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${TYPECONV}
+ tar zxf ${TYPECONV}.tar.gz
+ ./Patcher.sh ${TYPECONV}
+ ( cd ${TYPECONV} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove type_conv && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${TYPECONV} typeconv
+distclean::
+ rm -f ${TYPECONV}.tar.gz
+all: typeconv
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+VARIANTSLIB=variantslib-109.15.00
+${VARIANTSLIB}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+variantslib: ${VARIANTSLIB}.tar.gz findlib typeconv
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${VARIANTSLIB}
+ tar zxf ${VARIANTSLIB}.tar.gz
+ ./Patcher.sh ${VARIANTSLIB}
+ ( cd ${VARIANTSLIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove variantslib && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${VARIANTSLIB} variantslib
+distclean::
+ rm -f ${VARIANTSLIB}.tar.gz
+all: variantslib
+
+# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/
+PIPEBANG=pipebang-109.28.00
+${PIPEBANG}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@
+pipebang: ${PIPEBANG}.tar.gz findlib typeconv
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${PIPEBANG}
+ tar zxf ${PIPEBANG}.tar.gz
+ ./Patcher.sh ${PIPEBANG}
+ ( cd ${PIPEBANG} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove pa_pipebang && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${PIPEBANG} pipebang
+distclean::
+ rm -f ${PIPEBANG}.tar.gz
+all: pipebang
+
+# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/
+PAOUNIT=pa_ounit-109.36.00
+${PAOUNIT}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@
+paounit: ${PAOUNIT}.tar.gz findlib typeconv
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${PAOUNIT}
+ tar zxf ${PAOUNIT}.tar.gz
+ ./Patcher.sh ${PAOUNIT}
+ ( cd ${PAOUNIT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove pa_ounit && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${PAOUNIT} paounit
+distclean::
+ rm -f ${PAOUNIT}.tar.gz
+all: paounit
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+COMPARELIB=comparelib-109.15.00
+${COMPARELIB}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+comparelib: ${COMPARELIB}.tar.gz findlib typeconv
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${COMPARELIB}
+ tar zxf ${COMPARELIB}.tar.gz
+ ./Patcher.sh ${COMPARELIB}
+ ( cd ${COMPARELIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove comparelib && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${COMPARELIB} comparelib
+distclean::
+ rm -f ${COMPARELIB}.tar.gz
+all: comparelib
+
+# https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/
+BINPROT=bin_prot-109.30.00
+${BINPROT}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/$@
+binprot: ${BINPROT}.tar.gz findlib typeconv ounit
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${BINPROT}
+ tar zxf ${BINPROT}.tar.gz
+ ./Patcher.sh ${BINPROT}
+ ( cd ${BINPROT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove bin_prot && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${BINPROT} binprot
+distclean::
+ rm -f ${BINPROT}.tar.gz
+all: binprot
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+FIELDSLIB=fieldslib-109.15.00
+${FIELDSLIB}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+fieldslib: ${FIELDSLIB}.tar.gz findlib typeconv
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${FIELDSLIB}
+ tar zxf ${FIELDSLIB}.tar.gz
+ ./Patcher.sh ${FIELDSLIB}
+ ( cd ${FIELDSLIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove fieldslib && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${FIELDSLIB} fieldslib
+distclean::
+ rm -f ${FIELDSLIB}.tar.gz
+all: fieldslib
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+SEXPLIB=sexplib-109.15.00
+${SEXPLIB}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+sexplib: ${SEXPLIB}.tar.gz findlib typeconv
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${SEXPLIB}
+ tar zxf ${SEXPLIB}.tar.gz
+ ./Patcher.sh ${SEXPLIB}
+ ( cd ${SEXPLIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove sexplib && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${SEXPLIB} sexplib
+distclean::
+ rm -f ${SEXPLIB}.tar.gz
+all: sexplib
+
+# https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/
+HERELIB=herelib-109.35.00
+${HERELIB}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/$@
+herelib: ${HERELIB}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${HERELIB}
+ tar zxf ${HERELIB}.tar.gz
+ ./Patcher.sh ${HERELIB}
+ ( cd ${HERELIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ocamlfind remove herelib && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${HERELIB} herelib
+distclean::
+ rm -f ${HERELIB}.tar.gz
+all: herelib
+
+# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/
+COREKERNEL=core_kernel-109.37.00
+${COREKERNEL}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@
+corekernel: ${COREKERNEL}.tar.gz findlib variantslib sexplib fieldslib \
+ binprot comparelib paounit pipebang res ounit herelib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${COREKERNEL}
+ tar zxf ${COREKERNEL}.tar.gz
+ ./Patcher.sh ${COREKERNEL}
+ ( cd ${COREKERNEL} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove core_kernel && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${COREKERNEL} corekernel
+distclean::
+ rm -f ${COREKERNEL}.tar.gz
+all: core
+
+# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/
+CORE=core-109.37.00
+${CORE}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@
+core: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \
+ paounit pipebang res ounit corekernel
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CORE}
+ tar zxf ${CORE}.tar.gz
+ ./Patcher.sh ${CORE}
+ ( cd ${CORE} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove core && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CORE} core
+distclean::
+ rm -f ${CORE}.tar.gz
+all: core
+
+# https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/
+CUSTOMPRINTF=custom_printf-109.27.00
+${CUSTOMPRINTF}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/$@
+customprintf: ${CUSTOMPRINTF}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CUSTOMPRINTF}
+ tar zxf ${CUSTOMPRINTF}.tar.gz
+ ./Patcher.sh ${CUSTOMPRINTF}
+ ( cd ${CUSTOMPRINTF} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ocamlfind remove customprintf && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CUSTOMPRINTF} customprintf
+distclean::
+ rm -f ${CUSTOMPRINTF}.tar.gz
+all: customprintf
+
+# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/
+TEXTUTILS=textutils-109.36.00
+${TEXTUTILS}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@
+textutils: ${TEXTUTILS}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${TEXTUTILS}
+ tar zxf ${TEXTUTILS}.tar.gz
+ ./Patcher.sh ${TEXTUTILS}
+ ( cd ${TEXTUTILS} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ocamlfind remove textutils && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${TEXTUTILS} textutils
+distclean::
+ rm -f ${TEXTUTILS}.tar.gz
+all: textutils
+
+# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/
+COREEXTENDED=core_extended-109.36.00
+${COREEXTENDED}.tar.gz:
+ ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@
+coreextended: ${COREEXTENDED}.tar.gz findlib sexplib fieldslib binprot paounit \
+ pipebang core pcre res comparelib ounit
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${COREEXTENDED}
+ tar zxf ${COREEXTENDED}.tar.gz
+ ./Patcher.sh ${COREEXTENDED}
+ ( cd ${COREEXTENDED} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${COREEXTENDED} coreextended
+distclean::
+ rm -f ${COREEXTENDED}.tar.gz
+all: coreextended
+
+###########################################################################
+
+# http://erratique.ch/software/react
+REACT=react-0.9.3
+${REACT}.tbz:
+ ${WGET} http://erratique.ch/software/react/releases/$@
+react: ${REACT}.tbz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${REACT}
+ tar jxf ${REACT}.tbz
+ ./Patcher.sh ${REACT} oasis-common.patch
+ ( cd ${REACT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ./test.native && \
+ ocamlfind remove react && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${REACT} react
+distclean::
+ rm -f ${REACT}.tbz
+all: react
+
+# http://forge.ocamlcore.org/projects/ocaml-text/
+OCAMLTEXT=ocaml-text-0.5
+${OCAMLTEXT}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/641/$@
+ocamltext: ${OCAMLTEXT}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLTEXT}
+ tar zxf ${OCAMLTEXT}.tar.gz
+ ./Patcher.sh ${OCAMLTEXT} oasis-common.patch
+ ( cd ${OCAMLTEXT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} build && \
+ ${MAKE} test && \
+ ocamlfind remove text && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLTEXT} ocamltext
+distclean::
+ rm -f ${OCAMLTEXT}.tar.gz
+all: ocamltext
+
+# http://sourceforge.net/projects/savonet/files/ocaml-ssl/
+OCAMLSSL=ocaml-ssl-0.4.6
+${OCAMLSSL}.tar.gz:
+ ${WGET} http://voxel.dl.sourceforge.net/project/savonet/ocaml-ssl/0.4.6/$@
+ocamlssl: ${OCAMLSSL}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLSSL}
+ tar zxf ${OCAMLSSL}.tar.gz
+ ./Patcher.sh ${OCAMLSSL}
+ ( cd ${OCAMLSSL} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure && \
+ ${MAKE} && \
+ ocamlfind remove ssl && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLSSL} ocamlssl
+distclean::
+ rm -f ${OCAMLSSL}.tar.gz
+all: ocamlssl
+
+# http://ocsigen.org/lwt/install
+LWT=lwt-2.4.0
+${LWT}.tar.gz:
+ ${WGET} http://ocsigen.org/download/$@
+lwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl lablgtk
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${LWT}
+ tar zxf ${LWT}.tar.gz
+ ./Patcher.sh ${LWT}
+ ( cd ${LWT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ export C_INCLUDE_PATH=/usr/include:/opt/local/include && \
+ export LIBRARY_PATH=/usr/lib:/opt/local/lib && \
+ ./configure --enable-ssl --enable-react && \
+ ${MAKE} && \
+ ocamlfind remove lwt && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${LWT} lwt
+distclean::
+ rm -f ${LWT}.tar.gz
+all: lwt
+
+# http://forge.ocamlcore.org/projects/camlzip/
+CAMLZIP=camlzip-1.04
+${CAMLZIP}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/328/$@
+camlzip: ${CAMLZIP}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CAMLZIP}
+ tar zxf ${CAMLZIP}.tar.gz
+ ./Patcher.sh ${CAMLZIP}
+ ( cd ${CAMLZIP} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} all && \
+ ${MAKE} allopt && \
+ ${MAKE} install && \
+ ${MAKE} installopt && \
+ ocamlfind remove camlzip && \
+ ocamlfind install camlzip META )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CAMLZIP} camlzip
+distclean::
+ rm -f ${CAMLZIP}.tar.gz
+all: camlzip
+
+# http://forge.ocamlcore.org/projects/cryptokit/
+CRYPTOKIT=cryptokit-1.6
+${CRYPTOKIT}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/891/$@
+cryptokit: ${CRYPTOKIT}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CRYPTOKIT}
+ tar zxf ${CRYPTOKIT}.tar.gz
+ ./Patcher.sh ${CRYPTOKIT}
+ ( cd ${CRYPTOKIT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} build && \
+ ${MAKE} test && \
+ ocamlfind remove cryptokit && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CRYPTOKIT} cryptokit
+distclean::
+ rm -f ${CRYPTOKIT}.tar.gz
+all: cryptokit
+
+# https://bitbucket.org/mmottl
+SQLITE=sqlite3-ocaml-2.0.1
+${SQLITE}.tar.gz:
+ ${WGET} https://bitbucket.org/mmottl/sqlite3-ocaml/downloads/$@
+sqlite: ${SQLITE}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${SQLITE}
+ tar zxf ${SQLITE}.tar.gz
+ ./Patcher.sh ${SQLITE} oasis-common.patch
+ ( cd ${SQLITE} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove sqlite3 && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${SQLITE} sqlite
+distclean::
+ rm -f ${SQLITE}.tar.gz
+all: sqlite
+
+# http://gallium.inria.fr/~fpottier/menhir/
+MENHIR=menhir-20120123
+${MENHIR}.tar.gz:
+ ${WGET} http://gallium.inria.fr/~fpottier/menhir/$@
+menhir: ${MENHIR}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${MENHIR}
+ tar zxf ${MENHIR}.tar.gz
+ ./Patcher.sh ${MENHIR}
+ ( cd ${MENHIR} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} PREFIX=${PREFIX} && \
+ ocamlfind remove MenhirLib && \
+ ${MAKE} PREFIX=${PREFIX} install)
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${MENHIR} menhir
+distclean::
+ rm -f ${MENHIR}.tar.gz
+all: menhir
+
+# http://ocsigen.org/obrowser/install
+OBROWSER=obrowser-1.1.1
+${OBROWSER}.tar.gz:
+ ${WGET} http://ocsigen.org/download/$@
+obrowser: ${OBROWSER}.tar.gz lwt menhir
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OBROWSER}
+ tar zxf ${OBROWSER}.tar.gz
+ ./Patcher.sh ${OBROWSER}
+ ( cd ${OBROWSER} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} && \
+ ocamlfind remove obrowser && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OBROWSER} obrowser
+distclean::
+ rm -f ${OBROWSER}.tar.gz
+all: obrowser
+
+# http://hevea.inria.fr/old/
+HEVEA=hevea-2.09
+${HEVEA}.tar.gz:
+ ${WGET} http://hevea.inria.fr/old/$@
+hevea: ${HEVEA}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${HEVEA}
+ tar zxf ${HEVEA}.tar.gz
+ ./Patcher.sh ${HEVEA}
+ ( cd ${HEVEA} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} PREFIX=${PREFIX} && \
+ ${MAKE} PREFIX=${PREFIX} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${HEVEA} hevea
+distclean::
+ rm -f ${HEVEA}.tar.gz
+all: hevea
+
+# http://www.seas.upenn.edu/~bcpierce/unison/download/releases/
+UNISON=unison-2.45.4
+${UNISON}.tar.gz:
+ ${WGET} http://www.seas.upenn.edu/~bcpierce/unison/download/releases/unison-2.45.4/$@
+unison: ${UNISON}.tar.gz lablgtk
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${UNISON}
+ tar zxf ${UNISON}.tar.gz
+ ./Patcher.sh ${UNISON}
+ ( cd ${UNISON} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} UISTYLE=gtk2 && \
+ touch ${PREFIX}/bin/unison && \
+ ${MAKE} UISTYLE=gtk2 INSTALLDIR=${PREFIX}/bin/ install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${UNISON} unison
+distclean::
+ rm -f ${UNISON}.tar.gz
+all: unison
+
+# http://raevnos.pennmush.org/code/ocaml-mysql/
+MYSQL=ocaml-mysql-1.0.4
+${MYSQL}.tar.gz:
+ ${WGET} http://raevnos.pennmush.org/code/ocaml-mysql/$@
+mysql: ${MYSQL}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${MYSQL}
+ tar zxf ${MYSQL}.tar.gz
+ ./Patcher.sh ${MYSQL}
+ ( cd ${MYSQL} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ export CPPFLAGS=-I/opt/local/include/mysql5 && \
+ export LDFLAGS=-L/opt/local/lib/mysql5/mysql && \
+ ./configure -prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} opt && \
+ ocamlfind remove mysql && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${MYSQL} mysql
+distclean::
+ rm -f ${MYSQL}.tar.gz
+all: mysql
+
+# http://gallium.inria.fr/~guesdon/Tools/ocgi/
+OCGI=ocgi-0.5
+${OCGI}.tar.gz:
+ ${WGET} http://pauillac.inria.fr/~guesdon/Tools/Tars/$@
+ocgi: ${OCGI}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCGI}
+ tar zxf ${OCGI}.tar.gz
+ ./Patcher.sh ${OCGI}
+ ( cd ${OCGI} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure && \
+ ${MAKE} && \
+ ${MAKE} opt && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCGI} ocgi
+distclean::
+ rm -f ${OCGI}.tar.gz
+all: ocgi
+
+# http://tech.motion-twin.com/xmllight
+XMLLIGHT=xml-light-2.2
+${XMLLIGHT}.zip:
+ ${WGET} http://tech.motion-twin.com/zip/$@
+xmllight: ${XMLLIGHT}.zip
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf xml-light ${XMLLIGHT}
+ unzip ${XMLLIGHT}.zip && mv xml-light ${XMLLIGHT}
+ ./Patcher.sh ${XMLLIGHT}
+ ( cd ${XMLLIGHT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} xml_parser.ml && \
+ ${MAKE} all opt && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${XMLLIGHT} xml-light xmllight
+distclean::
+ rm -f ${XMLLIGHT}.zip
+all: xmllight
+
+# http://config-file.forge.ocamlcore.org/
+CONFIGFILE=config-file-1.1
+${CONFIGFILE}.tar.gz:
+ ${WGET} https://forge.ocamlcore.org/frs/download.php/845/$@
+configfile: ${CONFIGFILE}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CONFIGFILE}
+ tar zxf ${CONFIGFILE}.tar.gz
+ ./Patcher.sh ${CONFIGFILE}
+ ( cd ${CONFIGFILE} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix=${PREFIX} && \
+ ${MAKE} all && \
+ ocamlfind remove config-file && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CONFIGFILE} configfile
+distclean::
+ rm -f ${CONFIGFILE}.tar.gz
+all: configfile
+
+# http://erratique.ch/software/xmlm
+XMLM=xmlm-1.1.0
+${XMLM}.tbz:
+ ${WGET} http://erratique.ch/software/xmlm/releases/$@
+xmlm: ${XMLM}.tbz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${XMLM}
+ tar jxf ${XMLM}.tbz
+ ./Patcher.sh ${XMLM} oasis-common.patch
+ ( cd ${XMLM} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure --prefix ${PREFIX} && \
+ ocaml setup.ml -build && \
+ ocamlfind remove xmlm && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${XMLM} xmlm
+distclean::
+ rm -f ${XMLM}.tbz
+all: xmlm
+
+# http://forge.ocamlcore.org/projects/gtk-extras/
+LABLGTKEXTRAS=lablgtkextras-1.3
+${LABLGTKEXTRAS}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/1072/$@
+lablgtkextras: ${LABLGTKEXTRAS}.tar.gz lablgtk configfile xmlm
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${LABLGTKEXTRAS}
+ tar zxf ${LABLGTKEXTRAS}.tar.gz
+ ./Patcher.sh ${LABLGTKEXTRAS}
+ ( cd ${LABLGTKEXTRAS} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} all && \
+ ocamlfind remove lablgtk2-extras && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${LABLGTKEXTRAS} lablgtkextras
+distclean::
+ rm -f ${LABLGTKEXTRAS}.tar.gz
+all: lablgtkextras
+
+# https://bitbucket.org/skskeyserver/sks-keyserver/downloads
+SKS=sks-1.1.3
+${SKS}.tgz:
+ ${WGET} https://bitbucket.org/skskeyserver/sks-keyserver/downloads/$@
+sks: ${SKS}.tgz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${SKS}
+ tar zxf ${SKS}.tgz
+ ./Patcher.sh ${SKS}
+ ( cd ${SKS} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} dep PREFIX=${PREFIX} && \
+ ${MAKE} all PREFIX=${PREFIX} && \
+ ${MAKE} all.bc PREFIX=${PREFIX} && \
+ ${MAKE} install PREFIX=${PREFIX} )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${SKS} sks
+distclean::
+ rm -f ${SKS}.tgz
+all: sks
+
+# http://omake.metaprl.org/download.html
+OMAKE=omake-0.9.8.6
+${OMAKE}-0.rc1.tar.gz:
+ ${WGET} http://omake.metaprl.org/downloads/$@
+omake: ${OMAKE}-0.rc1.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OMAKE}
+ tar zxf ${OMAKE}-0.rc1.tar.gz
+ ./Patcher.sh ${OMAKE}
+ ( cd ${OMAKE} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ export PREFIX=${PREFIX} && \
+ ${MAKE} all && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OMAKE} omake
+distclean::
+ rm -f ${OMAKE}-0.rc1.tar.gz
+all: omake
+
+# http://alt-ergo.lri.fr/
+ALTERGO=alt-ergo-0.95
+${ALTERGO}.tar.gz:
+ ${WGET} http://alt-ergo.lri.fr/http/$(ALTERGO)/$@
+altergo: ${ALTERGO}.tar.gz ocamlgraph
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${ALTERGO}
+ tar zxf ${ALTERGO}.tar.gz
+ ./Patcher.sh ${ALTERGO}
+ ( cd ${ALTERGO} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure -prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${ALTERGO} altergo
+distclean::
+ rm -f ${ALTERGO}.tar.gz
+all: altergo
+
+# http://www.seas.upenn.edu/~harmony/
+BOOMERANG=boomerang-0.2
+${BOOMERANG}-source.tar.gz:
+ ${WGET} http://www.seas.upenn.edu/~harmony/download/$@
+boomerang: ${BOOMERANG}-source.tar.gz omake
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${BOOMERANG}
+ tar zxf ${BOOMERANG}-source.tar.gz && mv boomerang-20090902 ${BOOMERANG}
+ ./Patcher.sh ${BOOMERANG}
+ ( cd ${BOOMERANG} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ omake )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${BOOMERANG} boomerang
+distclean::
+ rm -f ${BOOMERANG}-source.tar.gz
+all: boomerang
+
+# https://github.com/yoriyuki/Camomile/wiki
+CAMOMILE=camomile-0.8.4
+${CAMOMILE}.tar.bz2:
+ ${WGET} https://github.com/downloads/yoriyuki/Camomile/$@
+camomile: ${CAMOMILE}.tar.bz2
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CAMOMILE}
+ tar xf ${CAMOMILE}.tar.bz2
+ ./Patcher.sh ${CAMOMILE}
+ ( cd ${CAMOMILE} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure -prefix ${PREFIX} && \
+ ${MAKE} && \
+ ocamlfind remove camomile && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CAMOMILE} camomile
+distclean::
+ rm -f ${CAMOMILE}.tar.bz2
+all: camomile
+
+# http://sanskrit.inria.fr/ZEN/
+ZEN=zen_2.3.2
+${ZEN}.tar.gz:
+ ${WGET} http://sanskrit.inria.fr/ZEN/$@
+zen: ${ZEN}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${ZEN}
+ tar zxf ${ZEN}.tar.gz && mv ZEN_* ${ZEN}
+ ./Patcher.sh ${ZEN}
+ ( cd ${ZEN} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} depend && \
+ ${MAKE} all && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${ZEN} zen
+distclean::
+ rm -f ${ZEN}.tar.gz
+all: zen
+
+# http://users-tima.imag.fr/vds/ouchet/index_fichiers/vsyml.html
+VSYML=vsyml-2010-04-06
+${VSYML}.tar.gz:
+ ${WGET} http://users-tima.imag.fr/vds/ouchet/vsyml/$@
+vsyml: ${VSYML}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${VSYML}
+ tar zxf ${VSYML}.tar.gz
+ ./Patcher.sh ${VSYML}
+ ( cd ${VSYML} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${VSYML} vsyml
+distclean::
+ rm -f ${VSYML}.tar.gz
+all: vsyml
+
+# http://projects.camlcity.org/projects/ocamlnet.html
+OCAMLNET=ocamlnet-3.5.1
+${OCAMLNET}.tar.gz:
+ ${WGET} http://download.camlcity.org/download/$@
+ocamlnet: ${OCAMLNET}.tar.gz findlib pcre lablgtk ocamlssl camlzip cryptokit
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLNET}
+ tar zxf ${OCAMLNET}.tar.gz
+ ./Patcher.sh ${OCAMLNET}
+ ( cd ${OCAMLNET} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure && \
+ ${MAKE} all && \
+ ${MAKE} opt && \
+ ocamlfind remove netsys && \
+ ocamlfind remove netshm && \
+ ocamlfind remove netstring && \
+ ocamlfind remove equeue && \
+ ocamlfind remove shell && \
+ ocamlfind remove rpc-generator && \
+ ocamlfind remove rpc-auth-local && \
+ ocamlfind remove rpc && \
+ ocamlfind remove pop && \
+ ocamlfind remove smtp && \
+ ocamlfind remove netclient && \
+ ocamlfind remove netcgi2 && \
+ ocamlfind remove netplex && \
+ ocamlfind remove netcgi2-plex && \
+ ocamlfind remove netcamlbox && \
+ ocamlfind remove netmulticore && \
+ ocamlfind remove netgssapi && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLNET} ocamlnet
+distclean::
+ rm -f ${OCAMLNET}.tar.gz
+all: ocamlnet
+
+# http://zoggy.github.io/ocamlrss/
+RSS=ocamlrss-2.2.2
+${RSS}.tar.gz:
+ ${WGET} http://zoggy.github.io/ocamlrss/$@
+rss: ${RSS}.tar.gz xmlm ocamlnet
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${RSS}
+ tar zxf ${RSS}.tar.gz
+ ./Patcher.sh ${RSS}
+ ( cd ${RSS} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} all && \
+ ocamlfind remove ocaml-rss && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${RSS} rss
+distclean::
+ rm -f ${RSS}.tar.gz
+all: rss
+
+# http://code.google.com/p/ocaml-extlib/
+EXTLIB=extlib-1.5.2
+${EXTLIB}.tar.gz:
+ ${WGET} http://ocaml-extlib.googlecode.com/files/$@
+extlib: ${EXTLIB}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${EXTLIB}
+ tar zxf ${EXTLIB}.tar.gz
+ ./Patcher.sh ${EXTLIB}
+ ( cd ${EXTLIB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocamlfind remove extlib && \
+ ocaml install.ml -b -n -doc )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${EXTLIB} extlib
+distclean::
+ rm -f ${EXTLIB}.tar.gz
+all: extlib
+
+# http://forge.ocamlcore.org/projects/ocaml-fileutils
+FILEUTILS=ocaml-fileutils-0.4.4
+${FILEUTILS}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/892/$@
+fileutils: ${FILEUTILS}.tar.gz findlib ounit
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${FILEUTILS}
+ tar xf ${FILEUTILS}.tar.gz
+ ./Patcher.sh ${FILEUTILS}
+ ( cd ${FILEUTILS} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ocamlfind remove fileutils && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${FILEUTILS} fileutils
+distclean::
+ rm -f ${FILEUTILS}.tar.gz
+all: fileutils
+
+# http://forge.ocamlcore.org/projects/odn
+ODN=ocaml-data-notation-0.0.10
+${ODN}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/1029/$@
+odn: ${ODN}.tar.gz findlib core ounit fileutils
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${ODN}
+ tar zxf ${ODN}.tar.gz
+ ./Patcher.sh ${ODN} oasis-common.patch
+ ( cd ${ODN} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove odn && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${ODN} odn
+distclean::
+ rm -f ${ODN}.tar.gz
+all: odn
+
+# http://forge.ocamlcore.org/projects/ocamlify
+OCAMLIFY=ocamlify-0.0.1
+${OCAMLIFY}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/379/$@
+ocamlify: ${OCAMLIFY}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLIFY}
+ tar zxf ${OCAMLIFY}.tar.gz
+ ./Patcher.sh ${OCAMLIFY} oasis-common.patch
+ ( cd ${OCAMLIFY} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ocaml setup.ml -build && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLIFY} ocamlify
+distclean::
+ rm -f ${OCAMLIFY}.tar.gz
+all: ocamlify
+
+# http://forge.ocamlcore.org/projects/ocaml-expect
+EXPECT=ocaml-expect-0.0.3
+${EXPECT}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/894/$@
+expect: ${EXPECT}.tar.gz findlib extlib pcre ounit
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${EXPECT}
+ tar zxf ${EXPECT}.tar.gz
+ ./Patcher.sh ${EXPECT} oasis-common.patch
+ ( cd ${EXPECT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ocaml setup.ml -configure && \
+ ocaml setup.ml -build && \
+ ocamlfind remove expect && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${EXPECT} expect
+distclean::
+ rm -f ${EXPECT}.tar.gz
+all: expect
+
+# http://forge.ocamlcore.org/projects/ocamlmod/
+OCAMLMOD=ocamlmod-0.0.3
+${OCAMLMOD}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/856/$@
+ocamlmod: ${OCAMLMOD}.tar.gz findlib fileutils pcre
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLMOD}
+ tar zxf ${OCAMLMOD}.tar.gz
+ ./Patcher.sh ${OCAMLMOD}
+ ( cd ${OCAMLMOD} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLMOD} ocamlmod
+distclean::
+ rm -f ${OCAMLMOD}.tar.gz
+all: ocamlmod
+
+# http://forge.ocamlcore.org/projects/oasis
+OASIS=oasis-0.3.0
+${OASIS}.tar.gz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/918/$@
+oasis: ${OASIS}.tar.gz findlib fileutils pcre extlib odn ocamlgraph ocamlify \
+ ounit expect ocamlmod
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OASIS}
+ tar zxf ${OASIS}.tar.gz
+ ./Patcher.sh ${OASIS} oasis-common.patch
+ ( cd ${OASIS} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ocaml setup.ml -build && \
+ ocamlfind remove oasis && \
+ ocamlfind remove userconf && \
+ ocamlfind remove plugin-loader && \
+ ocaml setup.ml -install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OASIS} oasis
+distclean::
+ rm -f ${OASIS}.tar.gz
+all: oasis
+
+# http://calendar.forge.ocamlcore.org/
+CALENDAR=calendar-2.03.2
+${CALENDAR}.tar.gz:
+ ${WGET} https://forge.ocamlcore.org/frs/download.php/915/$@
+calendar: ${CALENDAR}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CALENDAR}
+ tar zxf ${CALENDAR}.tar.gz
+ ./Patcher.sh ${CALENDAR}
+ ( cd ${CALENDAR} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CALENDAR} calendar
+distclean::
+ rm -f ${CALENDAR}.tar.gz
+all: calendar
+
+# http://gallium.inria.fr/camlimages/
+CAMLIMAGES=camlimages-4.0.1
+${CAMLIMAGES}.tar.gz:
+ ${WGET} https://bitbucket.org/camlspotter/camlimages/get/v4.0.1.tar.gz
+ mv v4.0.1.tar.gz $@
+camlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CAMLIMAGES}
+ tar xf ${CAMLIMAGES}.tar.gz
+ mv camlspotter-camlimages-c803efa9d5d3 ${CAMLIMAGES}
+ mv ${CAMLIMAGES}/doc/old/* ${CAMLIMAGES}/doc/
+ ./Patcher.sh ${CAMLIMAGES}
+ ( cd ${CAMLIMAGES} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ omake && \
+ ocamlfind remove camlimages && \
+ omake install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CAMLIMAGES} camlimages
+distclean::
+ rm -f ${CAMLIMAGES}.tar.gz
+all: camlimages
+
+# http://advi.inria.fr/
+ADVI=advi-1.10.2
+${ADVI}.tar.gz:
+ ${WGET} http://advi.inria.fr/$@
+advi: ${ADVI}.tar.gz findlib camlimages
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${ADVI}
+ tar zxf ${ADVI}.tar.gz
+ ./Patcher.sh ${ADVI}
+ ( cd ${ADVI} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${ADVI} advi
+distclean::
+ rm -f ${ADVI}.tar.gz
+all: advi
+
+# http://forge.ocamlcore.org/projects/camldbm
+DBM=camldbm-1.0
+${DBM}.tgz:
+ ${WGET} http://forge.ocamlcore.org/frs/download.php/728/$@
+dbm: ${DBM}.tgz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${DBM}
+ tar zxf ${DBM}.tgz
+ ./Patcher.sh ${DBM}
+ ( cd ${DBM} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${DBM} dbm
+distclean::
+ rm -f ${DBM}.tgz
+all: dbm
+
+# http://ocsigen.org/
+OCSIGEN=ocsigen-bundle-2.2.2
+${OCSIGEN}.tar.gz:
+ ${WGET} http://ocsigen.org/download/$@
+ocsigen: ${OCSIGEN}.tar.gz findlib lwt obrowser pcre ocamlnet ocamlssl \
+ sqlite camlzip cryptokit calendar dbm
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCSIGEN}
+ tar zxf ${OCSIGEN}.tar.gz
+ ./Patcher.sh ${OCSIGEN}
+ ( cd ${OCSIGEN} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ export OCSIGEN_USER=${USER}; export OCSIGEN_GROUP=everyone && \
+ ./configure --prefix=${PREFIX} && \
+ ${MAKE} && \
+ rm -rf ${PREFIX}/lib/ocaml/ocsigenserver/extensions && \
+ ocamlfind remove -destdir ${PREFIX}/lib/ocaml deriving-ocsigen && \
+ ocamlfind remove -destdir ${PREFIX}/lib/ocaml js_of_ocaml && \
+ ocamlfind remove -destdir ${PREFIX}/lib/ocaml ocsigenserver && \
+ ocamlfind remove -destdir ${PREFIX}/lib/ocaml tyxml && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCSIGEN} ocsigen
+distclean::
+ rm -f ${OCSIGEN}.tar.gz
+all: ocsigen
+
+# http://mldonkey.sourceforge.net/
+MLDONKEY=mldonkey-3.1.2
+${MLDONKEY}.tar.bz2:
+ ${WGET} http://freefr.dl.sourceforge.net/project/mldonkey/mldonkey/3.1.2/$@
+mldonkey: ${MLDONKEY}.tar.bz2 lablgtk
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${MLDONKEY}
+ tar zxf ${MLDONKEY}.tar.bz2
+ ./Patcher.sh ${MLDONKEY}
+ ( cd ${MLDONKEY} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure && \
+ ${MAKE} )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${MLDONKEY} mldonkey
+distclean::
+ rm -f ${MLDONKEY}.tar.bz2
+all: mldonkey
+
+# http://mjambon.com/releases/ocamlscript
+OCAMLSCRIPT=ocamlscript-2.0.3
+${OCAMLSCRIPT}.tar.gz:
+ ${WGET} http://mjambon.com/releases/ocamlscript/$@
+ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${OCAMLSCRIPT}
+ tar xf ${OCAMLSCRIPT}.tar.gz
+ ./Patcher.sh ${OCAMLSCRIPT}
+ ( cd ${OCAMLSCRIPT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} && \
+ ocamlfind remove ocamlscript && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${OCAMLSCRIPT} ocamlscript
+distclean::
+ rm -f ${OCAMLSCRIPT}.tar.bz2
+all: ocamlscript
+
+# https://forge.ocamlcore.org/projects/kaputt/
+KAPUTT=kaputt-1.2
+${KAPUTT}.tar.gz:
+ ${WGET} https://forge.ocamlcore.org/frs/download.php/987/$@
+kaputt: ${KAPUTT}.tar.gz findlib
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${KAPUTT}
+ tar zxf ${KAPUTT}.tar.gz
+ ./Patcher.sh ${KAPUTT}
+ ( cd ${KAPUTT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure -ocaml-prefix ${PREFIX} && \
+ ${MAKE} all && \
+ ocamlfind remove kaputt && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${KAPUTT} kaputt
+distclean::
+ rm -f ${KAPUTT}.tar.gz
+all: kaputt
+
+#http://www.coherentpdf.com/ocaml-libraries.html
+CAMLPDF=camlpdf-0.5
+${CAMLPDF}.tar.bz2:
+ ${WGET} http://www.coherentpdf.com/$@
+camlpdf: ${CAMLPDF}.tar.bz2
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CAMLPDF}
+ tar zxf ${CAMLPDF}.tar.bz2
+ ./Patcher.sh ${CAMLPDF}
+ ( cd ${CAMLPDF} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ${MAKE} all && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CAMLPDF} camlpdf
+distclean::
+ rm -f ${CAMLPDF}.tar.gz
+all: camlpdf
+
+# http://pauillac.inria.fr/~ddr/camlp5/
+CAMLP5=camlp5-6.10
+${CAMLP5}.tgz:
+ ${WGET} http://pauillac.inria.fr/~ddr/camlp5/distrib/src/$@
+camlp5: ${CAMLP5}.tgz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${CAMLP5}
+ tar zxf ${CAMLP5}.tgz
+ ./Patcher.sh ${CAMLP5}
+ ( cd ${CAMLP5} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure --transitional && \
+ ${MAKE} world.opt && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${CAMLP5} camlp5
+distclean::
+ rm -f ${CAMLP5}.tgz
+all: camlp5
+
+# http://opensource.geneanet.org/projects/geneweb
+GENEWEB=gw-6.05-src
+${GENEWEB}.tgz:
+ ${WGET} http://opensource.geneanet.org/attachments/download/190/$@
+geneweb: ${GENEWEB}.tgz camlp5
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${GENEWEB}
+ tar zxf ${GENEWEB}.tgz
+ ./Patcher.sh ${GENEWEB}
+ ( cd ${GENEWEB} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure && \
+ ${MAKE} )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${GENEWEB} geneweb
+distclean::
+ rm -f ${GENEWEB}.tgz
+all: geneweb
+
+# http://coq.inria.fr/download
+COQ=coq-8.4pl1
+${COQ}.tar.gz:
+ ${WGET} http://coq.inria.fr/distrib/V8.4pl1/files/$@
+coq: ${COQ}.tar.gz camlp5
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${COQ}
+ tar zxf ${COQ}.tar.gz
+ ./Patcher.sh ${COQ}
+ ( cd ${COQ} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure -prefix ${PREFIX} -with-doc no && \
+ ${MAKE} world && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${COQ} coq
+distclean::
+ rm -f ${COQ}.tar.gz
+all: coq
+
+# http://code.google.com/p/bitstring/
+
+BITSTRING=ocaml-bitstring-2.0.3
+${BITSTRING}.tar.gz:
+ ${WGET} http://bitstring.googlecode.com/files/$@
+bitstring: ${BITSTRING}.tar.gz findlib # cil FIXME ?
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${BITSTRING}
+ tar zxf ${BITSTRING}.tar.gz
+ ./Patcher.sh ${BITSTRING}
+ ( cd ${BITSTRING} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} check && \
+ ${MAKE} examples && \
+ ocamlfind remove bitstring && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${BITSTRING} bitstring
+distclean::
+ rm -f ${BITSTRING}.tar.gz
+all: bitstring
+
+# http://compcert.inria.fr
+COMPCERT=compcert-1.13
+${COMPCERT}.tgz:
+ ${WGET} http://compcert.inria.fr/release/$@
+compcert: ${COMPCERT}.tgz coq bitstring
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${COMPCERT}
+ tar zxf ${COMPCERT}.tgz
+ ./Patcher.sh ${COMPCERT}
+ ( cd ${COMPCERT} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure -prefix ${PREFIX} ppc-linux && \
+ ${MAKE} all && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${COMPCERT} compcert
+distclean::
+ rm -f ${COMPCERT}.tgz
+all: compcert
+
+# http://frama-c.com/
+FRAMAC=frama-c-Oxygen-20120901
+${FRAMAC}.tar.gz:
+ ${WGET} http://frama-c.com/download/$@
+framac: ${FRAMAC}.tar.gz lablgtk ocamlgraph altergo coq
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${FRAMAC}
+ tar zxf ${FRAMAC}.tar.gz
+ ./Patcher.sh ${FRAMAC}
+ ( cd ${FRAMAC} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ ./configure --enable-verbosemake --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ${MAKE} oracles && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+clean::
+ rm -rf ${FRAMAC} framac
+distclean::
+ rm -f ${FRAMAC}.tar.gz
+all: framac
+
+##################################################################
+### Template for new entries
+##################################################################
+
+FOO=
+${FOO}.tar.gz:
+ ${WGET} http://foo.bar.com/.../$@
+foo: ${FOO}.tar.gz
+ printf "%s " "$@" >/dev/tty
+ test -d ${PREFIX}
+ rm -rf ${FOO}
+ tar zxf ${FOO}.tar.gz
+ ./Patcher.sh ${FOO}
+ ( cd ${FOO} && \
+ export PATH=${PREFIX}/bin:$$PATH && \
+ sh ./configure --prefix ${PREFIX} && \
+ ${MAKE} && \
+ ocamlfind remove foo && \
+ ${MAKE} install )
+ echo ${VERSION} >$@
+xxclean::
+ rm -rf ${FOO} foo
+xxdistclean::
+ rm -f ${FOO}.tar.gz
+xxall: foo
+
+##################################################################
+
+.PHONY: clean
+
+.PHONY: distclean
+distclean::
+ ${MAKE} clean
+
+.PHONY: all
+all:
+ echo >/dev/tty
--- /dev/null
+#!/bin/sh
+
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2012 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+# usage:
+# Patcher.sh <directory> [<patchfile>]
+
+if [ -f "$1.patch" ]; then
+ echo "patch -d $1 -p1 < $1.patch"
+ patch -d $1 -p1 < "$1.patch"
+fi
+
+if [ -f "$1-$VERSION.patch" ]; then
+ echo "patch -d $1 -p1 < $1-$VERSION.patch"
+ patch -d $1 -p1 < "$1-$VERSION.patch"
+fi
+
+if [ -f "$2" ]; then
+ echo "patch -d $1 -l -p0 < $2"
+ patch -d $1 -l -p0 < "$2" || exit 0
+fi
--- /dev/null
+TODO:
+Understand why ocamlnet does not detect lablgtk, ocamlssl, camlzip, cryptokit
+
+TODO: cryptogps
+http://www.ocaml-programming.de/packages
+and make ocamlnet depend on it
+
+# TODO: lablgl
+# http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgl.html
+
+Haxe: missing a source archive of released version...
+# # http://code.google.com/p/haxe/source/browse/#svn%2Ftrunk
+# HAXE=haxe-2.10dev
+# haxe:
+# printf "%s " "$@" >/dev/tty
+# test -d ${PREFIX}
+# rm -rf ${HAXE}
+# tar zxf ${HAXE}.tar.gz
+# ./Patcher.sh ${HAXE}
+# ( cd ${HAXE} && \
+# export PATH=${PREFIX}/bin:$$PATH && \
+# make )
+# echo ${VERSION} >$@
+# clean::
+# rm -rf ${HAXE} haxe
+# all: haxe
--- /dev/null
+--- boomerang-0.2/OMakefile.orig 2010-06-07 15:01:55.000000000 +0200
++++ boomerang-0.2/OMakefile 2010-06-07 15:02:08.000000000 +0200
+@@ -126,7 +126,7 @@
+ ##############################################################################
+ # Include sub-directories
+
+-SUBDIRS = common src lenses examples doc
++SUBDIRS = common src lenses examples #doc
+
+ .SUBDIRS: $(SUBDIRS)
+
--- /dev/null
+--- camlimages-4.0.1.orig/OMakefile 2011-06-22 20:04:32.000000000 +0200
++++ camlimages-4.0.1/OMakefile 2013-02-19 15:35:38.000000000 +0100
+@@ -138,7 +138,7 @@
+ SUPPORTED_FORMATS+=jpeg
+ export
+
+- HAVE_TIFF = $(Check_header_library tiff, tiff.h, TIFFOpen)
++ HAVE_TIFF = false # $(Check_header_library tiff, tiff.h, TIFFOpen)
+ SUPPORT_TIFF = $(and $(HAVE_Z) $(HAVE_JPEG) $(HAVE_TIFF))
+ LDFLAGS_tiff=
+ if $(SUPPORT_TIFF)
--- /dev/null
+diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.1.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.1.ml
+--- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.1.ml 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_src/lib/versdep/4.00.1.ml 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,465 @@
++(* camlp5r pa_macro.cmo *)
++(* File generated by program: edit only if it does not compile. *)
++(* Copyright (c) INRIA 2007-2012 *)
++
++open Parsetree;;
++open Longident;;
++open Asttypes;;
++
++type ('a, 'b) choice =
++ Left of 'a
++ | Right of 'b
++;;
++
++let sys_ocaml_version = Sys.ocaml_version;;
++
++let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) =
++ let loc_at n lnum bolp =
++ {Lexing.pos_fname = if lnum = -1 then "" else fname;
++ Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n}
++ in
++ {Location.loc_start = loc_at bp lnum bolp;
++ Location.loc_end = loc_at ep lnuml bolpl;
++ Location.loc_ghost = bp = 0 && ep = 0}
++;;
++
++let loc_none =
++ let loc =
++ {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
++ Lexing.pos_cnum = -1}
++ in
++ {Location.loc_start = loc; Location.loc_end = loc;
++ Location.loc_ghost = true}
++;;
++
++let mkloc loc txt = {Location.txt = txt; Location.loc = loc};;
++let mknoloc txt = mkloc loc_none txt;;
++
++let ocaml_id_or_li_of_string_list loc sl =
++ let mkli s =
++ let rec loop f =
++ function
++ i :: il -> loop (fun s -> Ldot (f i, s)) il
++ | [] -> f s
++ in
++ loop (fun s -> Lident s)
++ in
++ match List.rev sl with
++ [] -> None
++ | s :: sl -> Some (mkli s (List.rev sl))
++;;
++
++let list_map_check f l =
++ let rec loop rev_l =
++ function
++ x :: l ->
++ begin match f x with
++ Some s -> loop (s :: rev_l) l
++ | None -> None
++ end
++ | [] -> Some (List.rev rev_l)
++ in
++ loop [] l
++;;
++
++let ocaml_value_description t p =
++ {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc}
++;;
++
++let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};;
++
++let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};;
++
++let ocaml_type_declaration params cl tk pf tm loc variance =
++ match list_map_check (fun s_opt -> s_opt) params with
++ Some params ->
++ let params = List.map (fun os -> Some (mknoloc os)) params in
++ Right
++ {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
++ ptype_private = pf; ptype_manifest = tm; ptype_loc = loc;
++ ptype_variance = variance}
++ | None -> Left "no '_' type param in this ocaml version"
++;;
++
++let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});;
++
++let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});;
++
++let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};;
++
++let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);;
++
++let ocaml_pmty_functor sloc s mt1 mt2 =
++ Pmty_functor (mkloc sloc s, mt1, mt2)
++;;
++
++let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);;
++
++let ocaml_pmty_with mt lcl =
++ let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl)
++;;
++
++let ocaml_ptype_abstract = Ptype_abstract;;
++
++let ocaml_ptype_record ltl priv =
++ Ptype_record
++ (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl)
++;;
++
++let ocaml_ptype_variant ctl priv =
++ try
++ let ctl =
++ List.map
++ (fun (c, tl, rto, loc) ->
++ if rto <> None then raise Exit else mknoloc c, tl, None, loc)
++ ctl
++ in
++ Some (Ptype_variant ctl)
++ with Exit -> None
++;;
++
++let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);;
++
++let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);;
++
++let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);;
++
++let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);;
++
++let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));;
++
++let ocaml_ptyp_variant catl clos sl_opt =
++ let catl =
++ List.map
++ (function
++ Left (c, a, tl) -> Rtag (c, a, tl)
++ | Right t -> Rinherit t)
++ catl
++ in
++ Some (Ptyp_variant (catl, clos, sl_opt))
++;;
++
++let ocaml_package_type li ltl =
++ mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl
++;;
++
++let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));;
++
++let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));;
++
++let ocaml_const_nativeint =
++ Some (fun s -> Const_nativeint (Nativeint.of_string s))
++;;
++
++let ocaml_pexp_apply f lel = Pexp_apply (f, lel);;
++
++let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;;
++
++let ocaml_pexp_assert fname loc e = Pexp_assert e;;
++
++let ocaml_pexp_construct li po chk_arity =
++ Pexp_construct (mknoloc li, po, chk_arity)
++;;
++
++let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);;
++
++let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);;
++
++let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);;
++
++let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);;
++
++let ocaml_pexp_ident li = Pexp_ident (mknoloc li);;
++
++let ocaml_pexp_letmodule =
++ Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e))
++;;
++
++let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);;
++
++let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));;
++
++let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);;
++
++let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));;
++
++let ocaml_pexp_override sel =
++ let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel
++;;
++
++let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option =
++ Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));;
++
++let ocaml_pexp_record lel eo =
++ let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in
++ Pexp_record (lel, eo)
++;;
++
++let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);;
++
++let ocaml_pexp_variant =
++ let pexp_variant_pat =
++ function
++ Pexp_variant (lab, eo) -> Some (lab, eo)
++ | _ -> None
++ in
++ let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in
++ Some (pexp_variant_pat, pexp_variant)
++;;
++
++let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);;
++
++let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);;
++
++let ocaml_ppat_construct li li_loc po chk_arity =
++ Ppat_construct (mkloc li_loc li, po, chk_arity)
++;;
++
++let ocaml_ppat_construct_args =
++ function
++ Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity)
++ | _ -> None
++;;
++
++let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);;
++
++let ocaml_ppat_record lpl is_closed =
++ let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in
++ Ppat_record (lpl, (if is_closed then Closed else Open))
++;;
++
++let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));;
++
++let ocaml_ppat_unpack =
++ Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt))
++;;
++
++let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);;
++
++let ocaml_ppat_variant =
++ let ppat_variant_pat =
++ function
++ Ppat_variant (lab, po) -> Some (lab, po)
++ | _ -> None
++ in
++ let ppat_variant (lab, po) = Ppat_variant (lab, po) in
++ Some (ppat_variant_pat, ppat_variant)
++;;
++
++let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);;
++
++let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);;
++
++let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);;
++
++let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);;
++
++let ocaml_psig_open li = Psig_open (mknoloc li);;
++
++let ocaml_psig_recmodule =
++ let f ntl =
++ let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in
++ Psig_recmodule ntl
++ in
++ Some f
++;;
++
++let ocaml_psig_type stl =
++ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl
++;;
++
++let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);;
++
++let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);;
++
++let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);;
++
++let ocaml_pstr_exn_rebind =
++ Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li))
++;;
++
++let ocaml_pstr_include = Some (fun me -> Pstr_include me);;
++
++let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);;
++
++let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);;
++
++let ocaml_pstr_open li = Pstr_open (mknoloc li);;
++
++let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);;
++
++let ocaml_pstr_recmodule =
++ let f nel =
++ Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel)
++ in
++ Some f
++;;
++
++let ocaml_pstr_type stl =
++ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl
++;;
++
++let ocaml_class_infos =
++ Some
++ (fun virt (sl, sloc) name expr loc variance ->
++ let params = List.map (fun s -> mkloc loc s) sl, sloc in
++ {pci_virt = virt; pci_params = params; pci_name = mkloc loc name;
++ pci_expr = expr; pci_loc = loc; pci_variance = variance})
++;;
++
++let ocaml_pmod_ident li = Pmod_ident (mknoloc li);;
++
++let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);;
++
++let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option =
++ Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));;
++
++let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);;
++
++let ocaml_pcf_init = Some (fun e -> Pcf_init e);;
++
++let ocaml_pcf_meth (s, pf, ovf, e, loc) =
++ let pf = if pf then Private else Public in
++ let ovf = if ovf then Override else Fresh in
++ Pcf_meth (mkloc loc s, pf, ovf, e)
++;;
++
++let ocaml_pcf_val (s, mf, ovf, e, loc) =
++ let mf = if mf then Mutable else Immutable in
++ let ovf = if ovf then Override else Fresh in
++ Pcf_val (mkloc loc s, mf, ovf, e)
++;;
++
++let ocaml_pcf_valvirt =
++ let ocaml_pcf (s, mf, t, loc) =
++ let mf = if mf then Mutable else Immutable in
++ Pcf_valvirt (mkloc loc s, mf, t)
++ in
++ Some ocaml_pcf
++;;
++
++let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);;
++
++let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));;
++
++let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));;
++
++let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));;
++
++let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));;
++
++let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));;
++
++let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);;
++
++let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));;
++
++let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);;
++
++let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);;
++
++let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);;
++
++let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));;
++
++let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));;
++
++let ocaml_pcty_signature =
++ let f (t, ctfl) =
++ let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in
++ Pcty_signature cs
++ in
++ Some f
++;;
++
++let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);;
++
++let ocaml_pwith_modsubst =
++ Some (fun loc me -> Pwith_modsubst (mkloc loc me))
++;;
++
++let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);;
++
++let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);;
++
++let module_prefix_can_be_in_first_record_label_only = true;;
++
++let split_or_patterns_with_bindings = false;;
++
++let has_records_with_with = true;;
++
++(* *)
++
++let jocaml_pstr_def : (_ -> _) option = None;;
++
++let jocaml_pexp_def : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_par : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;;
++
++let jocaml_pexp_spawn : (_ -> _) option = None;;
++
++let arg_rest =
++ function
++ Arg.Rest r -> Some r
++ | _ -> None
++;;
++
++let arg_set_string =
++ function
++ Arg.Set_string r -> Some r
++ | _ -> None
++;;
++
++let arg_set_int =
++ function
++ Arg.Set_int r -> Some r
++ | _ -> None
++;;
++
++let arg_set_float =
++ function
++ Arg.Set_float r -> Some r
++ | _ -> None
++;;
++
++let arg_symbol =
++ function
++ Arg.Symbol (s, f) -> Some (s, f)
++ | _ -> None
++;;
++
++let arg_tuple =
++ function
++ Arg.Tuple t -> Some t
++ | _ -> None
++;;
++
++let arg_bool =
++ function
++ Arg.Bool f -> Some f
++ | _ -> None
++;;
++
++let char_escaped = Char.escaped;;
++
++let hashtbl_mem = Hashtbl.mem;;
++
++let list_rev_append = List.rev_append;;
++
++let list_rev_map = List.rev_map;;
++
++let list_sort = List.sort;;
++
++let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;;
++
++let printf_ksprintf = Printf.ksprintf;;
++
++let string_contains = String.contains;;
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.1/parsing/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.cvsignore 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/.cvsignore 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1 @@
++*.cm[oi]
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.1/parsing/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.depend 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/.depend 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,4 @@
++asttypes.cmi : location.cmi
++location.cmi : ../utils/warnings.cmi
++longident.cmi :
++parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.1/parsing/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/Makefile 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/Makefile 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,19 @@
++# Id
++
++FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi
++INCL=-I ../utils
++
++all: $(FILES)
++
++clean:
++ rm -f *.cmi
++
++depend:
++ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend
++
++.SUFFIXES: .mli .cmi
++
++.mli.cmi:
++ $(OCAMLN)c $(INCL) -c $<
++
++include .depend
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/asttypes.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/asttypes.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/asttypes.mli 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,45 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
++
++type constant =
++ Const_int of int
++ | Const_char of char
++ | Const_string of string
++ | Const_float of string
++ | Const_int32 of int32
++ | Const_int64 of int64
++ | Const_nativeint of nativeint
++
++type rec_flag = Nonrecursive | Recursive | Default
++
++type direction_flag = Upto | Downto
++
++type private_flag = Private | Public
++
++type mutable_flag = Immutable | Mutable
++
++type virtual_flag = Virtual | Concrete
++
++type override_flag = Override | Fresh
++
++type closed_flag = Closed | Open
++
++type label = string
++
++type 'a loc = 'a Location.loc = {
++ txt : 'a;
++ loc : Location.t;
++}
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/location.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/location.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/location.mli 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,80 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Source code locations (ranges of positions), used in parsetree. *)
++
++open Format
++
++type t = {
++ loc_start: Lexing.position;
++ loc_end: Lexing.position;
++ loc_ghost: bool;
++}
++
++(* Note on the use of Lexing.position in this module.
++ If [pos_fname = ""], then use [!input_name] instead.
++ If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
++ re-parse the file to get the line and character numbers.
++ Else all fields are correct.
++*)
++
++val none : t
++(** An arbitrary value of type [t]; describes an empty ghost range. *)
++val in_file : string -> t;;
++(** Return an empty ghost range located in a given file. *)
++val init : Lexing.lexbuf -> string -> unit
++(** Set the file name and line number of the [lexbuf] to be the start
++ of the named file. *)
++val curr : Lexing.lexbuf -> t
++(** Get the location of the current token from the [lexbuf]. *)
++
++val symbol_rloc: unit -> t
++val symbol_gloc: unit -> t
++
++(** [rhs_loc n] returns the location of the symbol at position [n], starting
++ at 1, in the current parser rule. *)
++val rhs_loc: int -> t
++
++val input_name: string ref
++val input_lexbuf: Lexing.lexbuf option ref
++
++val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
++val print_loc: formatter -> t -> unit
++val print_error: formatter -> t -> unit
++val print_error_cur_file: formatter -> unit
++val print_warning: t -> formatter -> Warnings.t -> unit
++val prerr_warning: t -> Warnings.t -> unit
++val echo_eof: unit -> unit
++val reset: unit -> unit
++
++val highlight_locations: formatter -> t -> t -> bool
++
++type 'a loc = {
++ txt : 'a;
++ loc : t;
++}
++
++val mknoloc : 'a -> 'a loc
++val mkloc : 'a -> t -> 'a loc
++
++val print: formatter -> t -> unit
++val print_filename: formatter -> string -> unit
++
++val show_filename: string -> string
++ (** In -absname mode, return the absolute path for this filename.
++ Otherwise, returns the filename unchanged. *)
++
++
++val absname: bool ref
++
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/longident.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/longident.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/longident.mli 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,24 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Long identifiers, used in parsetree. *)
++
++type t =
++ Lident of string
++ | Ldot of t * string
++ | Lapply of t * t
++
++val flatten: t -> string list
++val last: t -> string
++val parse: string -> t
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/parsetree.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/parsetree.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/parsetree.mli 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,307 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Abstract syntax tree produced by parsing *)
++
++open Asttypes
++
++(* Type expressions for the core language *)
++
++type core_type =
++ { ptyp_desc: core_type_desc;
++ ptyp_loc: Location.t }
++
++and core_type_desc =
++ Ptyp_any
++ | Ptyp_var of string
++ | Ptyp_arrow of label * core_type * core_type
++ | Ptyp_tuple of core_type list
++ | Ptyp_constr of Longident.t loc * core_type list
++ | Ptyp_object of core_field_type list
++ | Ptyp_class of Longident.t loc * core_type list * label list
++ | Ptyp_alias of core_type * string
++ | Ptyp_variant of row_field list * bool * label list option
++ | Ptyp_poly of string list * core_type
++ | Ptyp_package of package_type
++
++
++and package_type = Longident.t loc * (Longident.t loc * core_type) list
++
++and core_field_type =
++ { pfield_desc: core_field_desc;
++ pfield_loc: Location.t }
++
++and core_field_desc =
++ Pfield of string * core_type
++ | Pfield_var
++
++and row_field =
++ Rtag of label * bool * core_type list
++ | Rinherit of core_type
++
++(* Type expressions for the class language *)
++
++type 'a class_infos =
++ { pci_virt: virtual_flag;
++ pci_params: string loc list * Location.t;
++ pci_name: string loc;
++ pci_expr: 'a;
++ pci_variance: (bool * bool) list;
++ pci_loc: Location.t }
++
++(* Value expressions for the core language *)
++
++type pattern =
++ { ppat_desc: pattern_desc;
++ ppat_loc: Location.t }
++
++and pattern_desc =
++ Ppat_any
++ | Ppat_var of string loc
++ | Ppat_alias of pattern * string loc
++ | Ppat_constant of constant
++ | Ppat_tuple of pattern list
++ | Ppat_construct of Longident.t loc * pattern option * bool
++ | Ppat_variant of label * pattern option
++ | Ppat_record of (Longident.t loc * pattern) list * closed_flag
++ | Ppat_array of pattern list
++ | Ppat_or of pattern * pattern
++ | Ppat_constraint of pattern * core_type
++ | Ppat_type of Longident.t loc
++ | Ppat_lazy of pattern
++ | Ppat_unpack of string loc
++
++type expression =
++ { pexp_desc: expression_desc;
++ pexp_loc: Location.t }
++
++and expression_desc =
++ Pexp_ident of Longident.t loc
++ | Pexp_constant of constant
++ | Pexp_let of rec_flag * (pattern * expression) list * expression
++ | Pexp_function of label * expression option * (pattern * expression) list
++ | Pexp_apply of expression * (label * expression) list
++ | Pexp_match of expression * (pattern * expression) list
++ | Pexp_try of expression * (pattern * expression) list
++ | Pexp_tuple of expression list
++ | Pexp_construct of Longident.t loc * expression option * bool
++ | Pexp_variant of label * expression option
++ | Pexp_record of (Longident.t loc * expression) list * expression option
++ | Pexp_field of expression * Longident.t loc
++ | Pexp_setfield of expression * Longident.t loc * expression
++ | Pexp_array of expression list
++ | Pexp_ifthenelse of expression * expression * expression option
++ | Pexp_sequence of expression * expression
++ | Pexp_while of expression * expression
++ | Pexp_for of string loc * expression * expression * direction_flag * expression
++ | Pexp_constraint of expression * core_type option * core_type option
++ | Pexp_when of expression * expression
++ | Pexp_send of expression * string
++ | Pexp_new of Longident.t loc
++ | Pexp_setinstvar of string loc * expression
++ | Pexp_override of (string loc * expression) list
++ | Pexp_letmodule of string loc * module_expr * expression
++ | Pexp_assert of expression
++ | Pexp_assertfalse
++ | Pexp_lazy of expression
++ | Pexp_poly of expression * core_type option
++ | Pexp_object of class_structure
++ | Pexp_newtype of string * expression
++ | Pexp_pack of module_expr
++ | Pexp_open of Longident.t loc * expression
++
++(* Value descriptions *)
++
++and value_description =
++ { pval_type: core_type;
++ pval_prim: string list;
++ pval_loc : Location.t
++ }
++
++(* Type declarations *)
++
++and type_declaration =
++ { ptype_params: string loc option list;
++ ptype_cstrs: (core_type * core_type * Location.t) list;
++ ptype_kind: type_kind;
++ ptype_private: private_flag;
++ ptype_manifest: core_type option;
++ ptype_variance: (bool * bool) list;
++ ptype_loc: Location.t }
++
++and type_kind =
++ Ptype_abstract
++ | Ptype_variant of
++ (string loc * core_type list * core_type option * Location.t) list
++ | Ptype_record of
++ (string loc * mutable_flag * core_type * Location.t) list
++
++and exception_declaration = core_type list
++
++(* Type expressions for the class language *)
++
++and class_type =
++ { pcty_desc: class_type_desc;
++ pcty_loc: Location.t }
++
++and class_type_desc =
++ Pcty_constr of Longident.t loc * core_type list
++ | Pcty_signature of class_signature
++ | Pcty_fun of label * core_type * class_type
++
++and class_signature = {
++ pcsig_self : core_type;
++ pcsig_fields : class_type_field list;
++ pcsig_loc : Location.t;
++ }
++
++and class_type_field = {
++ pctf_desc : class_type_field_desc;
++ pctf_loc : Location.t;
++ }
++
++and class_type_field_desc =
++ Pctf_inher of class_type
++ | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
++ | Pctf_virt of (string * private_flag * core_type)
++ | Pctf_meth of (string * private_flag * core_type)
++ | Pctf_cstr of (core_type * core_type)
++
++and class_description = class_type class_infos
++
++and class_type_declaration = class_type class_infos
++
++(* Value expressions for the class language *)
++
++and class_expr =
++ { pcl_desc: class_expr_desc;
++ pcl_loc: Location.t }
++
++and class_expr_desc =
++ Pcl_constr of Longident.t loc * core_type list
++ | Pcl_structure of class_structure
++ | Pcl_fun of label * expression option * pattern * class_expr
++ | Pcl_apply of class_expr * (label * expression) list
++ | Pcl_let of rec_flag * (pattern * expression) list * class_expr
++ | Pcl_constraint of class_expr * class_type
++
++and class_structure = {
++ pcstr_pat : pattern;
++ pcstr_fields : class_field list;
++ }
++
++and class_field = {
++ pcf_desc : class_field_desc;
++ pcf_loc : Location.t;
++ }
++
++and class_field_desc =
++ Pcf_inher of override_flag * class_expr * string option
++ | Pcf_valvirt of (string loc * mutable_flag * core_type)
++ | Pcf_val of (string loc * mutable_flag * override_flag * expression)
++ | Pcf_virt of (string loc * private_flag * core_type)
++ | Pcf_meth of (string loc * private_flag *override_flag * expression)
++ | Pcf_constr of (core_type * core_type)
++ | Pcf_init of expression
++
++and class_declaration = class_expr class_infos
++
++(* Type expressions for the module language *)
++
++and module_type =
++ { pmty_desc: module_type_desc;
++ pmty_loc: Location.t }
++
++and module_type_desc =
++ Pmty_ident of Longident.t loc
++ | Pmty_signature of signature
++ | Pmty_functor of string loc * module_type * module_type
++ | Pmty_with of module_type * (Longident.t loc * with_constraint) list
++ | Pmty_typeof of module_expr
++
++and signature = signature_item list
++
++and signature_item =
++ { psig_desc: signature_item_desc;
++ psig_loc: Location.t }
++
++and signature_item_desc =
++ Psig_value of string loc * value_description
++ | Psig_type of (string loc * type_declaration) list
++ | Psig_exception of string loc * exception_declaration
++ | Psig_module of string loc * module_type
++ | Psig_recmodule of (string loc * module_type) list
++ | Psig_modtype of string loc * modtype_declaration
++ | Psig_open of Longident.t loc
++ | Psig_include of module_type
++ | Psig_class of class_description list
++ | Psig_class_type of class_type_declaration list
++
++and modtype_declaration =
++ Pmodtype_abstract
++ | Pmodtype_manifest of module_type
++
++and with_constraint =
++ Pwith_type of type_declaration
++ | Pwith_module of Longident.t loc
++ | Pwith_typesubst of type_declaration
++ | Pwith_modsubst of Longident.t loc
++
++(* Value expressions for the module language *)
++
++and module_expr =
++ { pmod_desc: module_expr_desc;
++ pmod_loc: Location.t }
++
++and module_expr_desc =
++ Pmod_ident of Longident.t loc
++ | Pmod_structure of structure
++ | Pmod_functor of string loc * module_type * module_expr
++ | Pmod_apply of module_expr * module_expr
++ | Pmod_constraint of module_expr * module_type
++ | Pmod_unpack of expression
++
++and structure = structure_item list
++
++and structure_item =
++ { pstr_desc: structure_item_desc;
++ pstr_loc: Location.t }
++
++and structure_item_desc =
++ Pstr_eval of expression
++ | Pstr_value of rec_flag * (pattern * expression) list
++ | Pstr_primitive of string loc * value_description
++ | Pstr_type of (string loc * type_declaration) list
++ | Pstr_exception of string loc * exception_declaration
++ | Pstr_exn_rebind of string loc * Longident.t loc
++ | Pstr_module of string loc * module_expr
++ | Pstr_recmodule of (string loc * module_type * module_expr) list
++ | Pstr_modtype of string loc * module_type
++ | Pstr_open of Longident.t loc
++ | Pstr_class of class_declaration list
++ | Pstr_class_type of class_type_declaration list
++ | Pstr_include of module_expr
++
++(* Toplevel phrases *)
++
++type toplevel_phrase =
++ Ptop_def of structure
++ | Ptop_dir of string * directive_argument
++
++and directive_argument =
++ Pdir_none
++ | Pdir_string of string
++ | Pdir_int of int
++ | Pdir_ident of Longident.t
++ | Pdir_bool of bool
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.1/utils/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.cvsignore 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/.cvsignore 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1 @@
++*.cm[oix]
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.depend camlp5-6.06/ocaml_stuff/4.00.1/utils/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.depend 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/.depend 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,4 @@
++pconfig.cmo : pconfig.cmi
++pconfig.cmx : pconfig.cmi
++pconfig.cmi :
++warnings.cmi :
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.1/utils/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/Makefile 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/Makefile 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,27 @@
++# Id
++
++FILES=warnings.cmi pconfig.cmo
++INCL=
++
++all: $(FILES)
++
++opt: pconfig.cmx
++
++clean:
++ rm -f *.cm[oix] *.o
++
++depend:
++ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend
++
++.SUFFIXES: .mli .cmi .ml .cmo .cmx
++
++.mli.cmi:
++ $(OCAMLN)c $(INCL) -c $<
++
++.ml.cmo:
++ $(OCAMLN)c $(INCL) -c $<
++
++.ml.cmx:
++ $(OCAMLN)opt $(INCL) -c $<
++
++include .depend
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.ml
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.ml 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.ml 2012-07-31 16:53:40.000000000 +0200
+@@ -0,0 +1,4 @@
++let ocaml_version = "4.00.1"
++let ocaml_name = "ocaml"
++let ast_impl_magic_number = "Caml1999M015"
++let ast_intf_magic_number = "Caml1999N014"
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.mli 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,4 @@
++val ocaml_version : string
++val ocaml_name : string
++val ast_impl_magic_number : string
++val ast_intf_magic_number : string
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.1/utils/warnings.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/warnings.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/warnings.mli 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,75 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1998 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++open Format
++
++type t =
++ | Comment_start (* 1 *)
++ | Comment_not_end (* 2 *)
++ | Deprecated (* 3 *)
++ | Fragile_match of string (* 4 *)
++ | Partial_application (* 5 *)
++ | Labels_omitted (* 6 *)
++ | Method_override of string list (* 7 *)
++ | Partial_match of string (* 8 *)
++ | Non_closed_record_pattern of string (* 9 *)
++ | Statement_type (* 10 *)
++ | Unused_match (* 11 *)
++ | Unused_pat (* 12 *)
++ | Instance_variable_override of string list (* 13 *)
++ | Illegal_backslash (* 14 *)
++ | Implicit_public_methods of string list (* 15 *)
++ | Unerasable_optional_argument (* 16 *)
++ | Undeclared_virtual_method of string (* 17 *)
++ | Not_principal of string (* 18 *)
++ | Without_principality of string (* 19 *)
++ | Unused_argument (* 20 *)
++ | Nonreturning_statement (* 21 *)
++ | Camlp4 of string (* 22 *)
++ | Useless_record_with (* 23 *)
++ | Bad_module_name of string (* 24 *)
++ | All_clauses_guarded (* 25 *)
++ | Unused_var of string (* 26 *)
++ | Unused_var_strict of string (* 27 *)
++ | Wildcard_arg_to_constant_constr (* 28 *)
++ | Eol_in_string (* 29 *)
++ | Duplicate_definitions of string * string * string * string (*30 *)
++ | Multiple_definition of string * string * string (* 31 *)
++ | Unused_value_declaration of string (* 32 *)
++ | Unused_open of string (* 33 *)
++ | Unused_type_declaration of string (* 34 *)
++ | Unused_for_index of string (* 35 *)
++ | Unused_ancestor of string (* 36 *)
++ | Unused_constructor of string * bool * bool (* 37 *)
++ | Unused_exception of string * bool (* 38 *)
++ | Unused_rec_flag (* 39 *)
++;;
++
++val parse_options : bool -> string -> unit;;
++
++val is_active : t -> bool;;
++val is_error : t -> bool;;
++
++val defaults_w : string;;
++val defaults_warn_error : string;;
++
++val print : formatter -> t -> int;;
++ (* returns the number of newlines in the printed string *)
++
++
++exception Errors of int;;
++
++val check_fatal : unit -> unit;;
++
++val help_warnings: unit -> unit
+--- camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli.orig 2013-02-18 15:14:16.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli 2013-02-18 15:14:31.000000000 +0100
+@@ -54,6 +54,10 @@
+ | Unused_constructor of string * bool * bool (* 37 *)
+ | Unused_exception of string * bool (* 38 *)
+ | Unused_rec_flag (* 39 *)
++ | Name_out_of_scope of string list * bool (* 40 *)
++ | Ambiguous_name of string list * bool (* 41 *)
++ | Disambiguated_name of string (* 42 *)
++ | Nonoptional_label of string (* 43 *)
+ ;;
+
+ val parse_options : bool -> string -> unit;;
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oi]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++asttypes.cmi : location.cmi
++location.cmi : ../utils/warnings.cmi
++longident.cmi :
++parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,19 @@
++# Id
++
++FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi
++INCL=-I ../utils
++
++all: $(FILES)
++
++clean:
++ rm -f *.cmi
++
++depend:
++ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend
++
++.SUFFIXES: .mli .cmi
++
++.mli.cmi:
++ $(OCAMLN)c $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,45 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
++
++type constant =
++ Const_int of int
++ | Const_char of char
++ | Const_string of string
++ | Const_float of string
++ | Const_int32 of int32
++ | Const_int64 of int64
++ | Const_nativeint of nativeint
++
++type rec_flag = Nonrecursive | Recursive | Default
++
++type direction_flag = Upto | Downto
++
++type private_flag = Private | Public
++
++type mutable_flag = Immutable | Mutable
++
++type virtual_flag = Virtual | Concrete
++
++type override_flag = Override | Fresh
++
++type closed_flag = Closed | Open
++
++type label = string
++
++type 'a loc = 'a Location.loc = {
++ txt : 'a;
++ loc : Location.t;
++}
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,80 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Source code locations (ranges of positions), used in parsetree. *)
++
++open Format
++
++type t = {
++ loc_start: Lexing.position;
++ loc_end: Lexing.position;
++ loc_ghost: bool;
++}
++
++(* Note on the use of Lexing.position in this module.
++ If [pos_fname = ""], then use [!input_name] instead.
++ If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
++ re-parse the file to get the line and character numbers.
++ Else all fields are correct.
++*)
++
++val none : t
++(** An arbitrary value of type [t]; describes an empty ghost range. *)
++val in_file : string -> t;;
++(** Return an empty ghost range located in a given file. *)
++val init : Lexing.lexbuf -> string -> unit
++(** Set the file name and line number of the [lexbuf] to be the start
++ of the named file. *)
++val curr : Lexing.lexbuf -> t
++(** Get the location of the current token from the [lexbuf]. *)
++
++val symbol_rloc: unit -> t
++val symbol_gloc: unit -> t
++
++(** [rhs_loc n] returns the location of the symbol at position [n], starting
++ at 1, in the current parser rule. *)
++val rhs_loc: int -> t
++
++val input_name: string ref
++val input_lexbuf: Lexing.lexbuf option ref
++
++val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
++val print_loc: formatter -> t -> unit
++val print_error: formatter -> t -> unit
++val print_error_cur_file: formatter -> unit
++val print_warning: t -> formatter -> Warnings.t -> unit
++val prerr_warning: t -> Warnings.t -> unit
++val echo_eof: unit -> unit
++val reset: unit -> unit
++
++val highlight_locations: formatter -> t -> t -> bool
++
++type 'a loc = {
++ txt : 'a;
++ loc : t;
++}
++
++val mknoloc : 'a -> 'a loc
++val mkloc : 'a -> t -> 'a loc
++
++val print: formatter -> t -> unit
++val print_filename: formatter -> string -> unit
++
++val show_filename: string -> string
++ (** In -absname mode, return the absolute path for this filename.
++ Otherwise, returns the filename unchanged. *)
++
++
++val absname: bool ref
++
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,24 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Long identifiers, used in parsetree. *)
++
++type t =
++ Lident of string
++ | Ldot of t * string
++ | Lapply of t * t
++
++val flatten: t -> string list
++val last: t -> string
++val parse: string -> t
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,307 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Abstract syntax tree produced by parsing *)
++
++open Asttypes
++
++(* Type expressions for the core language *)
++
++type core_type =
++ { ptyp_desc: core_type_desc;
++ ptyp_loc: Location.t }
++
++and core_type_desc =
++ Ptyp_any
++ | Ptyp_var of string
++ | Ptyp_arrow of label * core_type * core_type
++ | Ptyp_tuple of core_type list
++ | Ptyp_constr of Longident.t loc * core_type list
++ | Ptyp_object of core_field_type list
++ | Ptyp_class of Longident.t loc * core_type list * label list
++ | Ptyp_alias of core_type * string
++ | Ptyp_variant of row_field list * bool * label list option
++ | Ptyp_poly of string list * core_type
++ | Ptyp_package of package_type
++
++
++and package_type = Longident.t loc * (Longident.t loc * core_type) list
++
++and core_field_type =
++ { pfield_desc: core_field_desc;
++ pfield_loc: Location.t }
++
++and core_field_desc =
++ Pfield of string * core_type
++ | Pfield_var
++
++and row_field =
++ Rtag of label * bool * core_type list
++ | Rinherit of core_type
++
++(* Type expressions for the class language *)
++
++type 'a class_infos =
++ { pci_virt: virtual_flag;
++ pci_params: string loc list * Location.t;
++ pci_name: string loc;
++ pci_expr: 'a;
++ pci_variance: (bool * bool) list;
++ pci_loc: Location.t }
++
++(* Value expressions for the core language *)
++
++type pattern =
++ { ppat_desc: pattern_desc;
++ ppat_loc: Location.t }
++
++and pattern_desc =
++ Ppat_any
++ | Ppat_var of string loc
++ | Ppat_alias of pattern * string loc
++ | Ppat_constant of constant
++ | Ppat_tuple of pattern list
++ | Ppat_construct of Longident.t loc * pattern option * bool
++ | Ppat_variant of label * pattern option
++ | Ppat_record of (Longident.t loc * pattern) list * closed_flag
++ | Ppat_array of pattern list
++ | Ppat_or of pattern * pattern
++ | Ppat_constraint of pattern * core_type
++ | Ppat_type of Longident.t loc
++ | Ppat_lazy of pattern
++ | Ppat_unpack of string loc
++
++type expression =
++ { pexp_desc: expression_desc;
++ pexp_loc: Location.t }
++
++and expression_desc =
++ Pexp_ident of Longident.t loc
++ | Pexp_constant of constant
++ | Pexp_let of rec_flag * (pattern * expression) list * expression
++ | Pexp_function of label * expression option * (pattern * expression) list
++ | Pexp_apply of expression * (label * expression) list
++ | Pexp_match of expression * (pattern * expression) list
++ | Pexp_try of expression * (pattern * expression) list
++ | Pexp_tuple of expression list
++ | Pexp_construct of Longident.t loc * expression option * bool
++ | Pexp_variant of label * expression option
++ | Pexp_record of (Longident.t loc * expression) list * expression option
++ | Pexp_field of expression * Longident.t loc
++ | Pexp_setfield of expression * Longident.t loc * expression
++ | Pexp_array of expression list
++ | Pexp_ifthenelse of expression * expression * expression option
++ | Pexp_sequence of expression * expression
++ | Pexp_while of expression * expression
++ | Pexp_for of string loc * expression * expression * direction_flag * expression
++ | Pexp_constraint of expression * core_type option * core_type option
++ | Pexp_when of expression * expression
++ | Pexp_send of expression * string
++ | Pexp_new of Longident.t loc
++ | Pexp_setinstvar of string loc * expression
++ | Pexp_override of (string loc * expression) list
++ | Pexp_letmodule of string loc * module_expr * expression
++ | Pexp_assert of expression
++ | Pexp_assertfalse
++ | Pexp_lazy of expression
++ | Pexp_poly of expression * core_type option
++ | Pexp_object of class_structure
++ | Pexp_newtype of string * expression
++ | Pexp_pack of module_expr
++ | Pexp_open of Longident.t loc * expression
++
++(* Value descriptions *)
++
++and value_description =
++ { pval_type: core_type;
++ pval_prim: string list;
++ pval_loc : Location.t
++ }
++
++(* Type declarations *)
++
++and type_declaration =
++ { ptype_params: string loc option list;
++ ptype_cstrs: (core_type * core_type * Location.t) list;
++ ptype_kind: type_kind;
++ ptype_private: private_flag;
++ ptype_manifest: core_type option;
++ ptype_variance: (bool * bool) list;
++ ptype_loc: Location.t }
++
++and type_kind =
++ Ptype_abstract
++ | Ptype_variant of
++ (string loc * core_type list * core_type option * Location.t) list
++ | Ptype_record of
++ (string loc * mutable_flag * core_type * Location.t) list
++
++and exception_declaration = core_type list
++
++(* Type expressions for the class language *)
++
++and class_type =
++ { pcty_desc: class_type_desc;
++ pcty_loc: Location.t }
++
++and class_type_desc =
++ Pcty_constr of Longident.t loc * core_type list
++ | Pcty_signature of class_signature
++ | Pcty_fun of label * core_type * class_type
++
++and class_signature = {
++ pcsig_self : core_type;
++ pcsig_fields : class_type_field list;
++ pcsig_loc : Location.t;
++ }
++
++and class_type_field = {
++ pctf_desc : class_type_field_desc;
++ pctf_loc : Location.t;
++ }
++
++and class_type_field_desc =
++ Pctf_inher of class_type
++ | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
++ | Pctf_virt of (string * private_flag * core_type)
++ | Pctf_meth of (string * private_flag * core_type)
++ | Pctf_cstr of (core_type * core_type)
++
++and class_description = class_type class_infos
++
++and class_type_declaration = class_type class_infos
++
++(* Value expressions for the class language *)
++
++and class_expr =
++ { pcl_desc: class_expr_desc;
++ pcl_loc: Location.t }
++
++and class_expr_desc =
++ Pcl_constr of Longident.t loc * core_type list
++ | Pcl_structure of class_structure
++ | Pcl_fun of label * expression option * pattern * class_expr
++ | Pcl_apply of class_expr * (label * expression) list
++ | Pcl_let of rec_flag * (pattern * expression) list * class_expr
++ | Pcl_constraint of class_expr * class_type
++
++and class_structure = {
++ pcstr_pat : pattern;
++ pcstr_fields : class_field list;
++ }
++
++and class_field = {
++ pcf_desc : class_field_desc;
++ pcf_loc : Location.t;
++ }
++
++and class_field_desc =
++ Pcf_inher of override_flag * class_expr * string option
++ | Pcf_valvirt of (string loc * mutable_flag * core_type)
++ | Pcf_val of (string loc * mutable_flag * override_flag * expression)
++ | Pcf_virt of (string loc * private_flag * core_type)
++ | Pcf_meth of (string loc * private_flag *override_flag * expression)
++ | Pcf_constr of (core_type * core_type)
++ | Pcf_init of expression
++
++and class_declaration = class_expr class_infos
++
++(* Type expressions for the module language *)
++
++and module_type =
++ { pmty_desc: module_type_desc;
++ pmty_loc: Location.t }
++
++and module_type_desc =
++ Pmty_ident of Longident.t loc
++ | Pmty_signature of signature
++ | Pmty_functor of string loc * module_type * module_type
++ | Pmty_with of module_type * (Longident.t loc * with_constraint) list
++ | Pmty_typeof of module_expr
++
++and signature = signature_item list
++
++and signature_item =
++ { psig_desc: signature_item_desc;
++ psig_loc: Location.t }
++
++and signature_item_desc =
++ Psig_value of string loc * value_description
++ | Psig_type of (string loc * type_declaration) list
++ | Psig_exception of string loc * exception_declaration
++ | Psig_module of string loc * module_type
++ | Psig_recmodule of (string loc * module_type) list
++ | Psig_modtype of string loc * modtype_declaration
++ | Psig_open of Longident.t loc
++ | Psig_include of module_type
++ | Psig_class of class_description list
++ | Psig_class_type of class_type_declaration list
++
++and modtype_declaration =
++ Pmodtype_abstract
++ | Pmodtype_manifest of module_type
++
++and with_constraint =
++ Pwith_type of type_declaration
++ | Pwith_module of Longident.t loc
++ | Pwith_typesubst of type_declaration
++ | Pwith_modsubst of Longident.t loc
++
++(* Value expressions for the module language *)
++
++and module_expr =
++ { pmod_desc: module_expr_desc;
++ pmod_loc: Location.t }
++
++and module_expr_desc =
++ Pmod_ident of Longident.t loc
++ | Pmod_structure of structure
++ | Pmod_functor of string loc * module_type * module_expr
++ | Pmod_apply of module_expr * module_expr
++ | Pmod_constraint of module_expr * module_type
++ | Pmod_unpack of expression
++
++and structure = structure_item list
++
++and structure_item =
++ { pstr_desc: structure_item_desc;
++ pstr_loc: Location.t }
++
++and structure_item_desc =
++ Pstr_eval of expression
++ | Pstr_value of rec_flag * (pattern * expression) list
++ | Pstr_primitive of string loc * value_description
++ | Pstr_type of (string loc * type_declaration) list
++ | Pstr_exception of string loc * exception_declaration
++ | Pstr_exn_rebind of string loc * Longident.t loc
++ | Pstr_module of string loc * module_expr
++ | Pstr_recmodule of (string loc * module_type * module_expr) list
++ | Pstr_modtype of string loc * module_type
++ | Pstr_open of Longident.t loc
++ | Pstr_class of class_declaration list
++ | Pstr_class_type of class_type_declaration list
++ | Pstr_include of module_expr
++
++(* Toplevel phrases *)
++
++type toplevel_phrase =
++ Ptop_def of structure
++ | Ptop_dir of string * directive_argument
++
++and directive_argument =
++ Pdir_none
++ | Pdir_string of string
++ | Pdir_int of int
++ | Pdir_ident of Longident.t
++ | Pdir_bool of bool
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oix]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,2 @@
++pconfig.cmo: pconfig.cmi
++pconfig.cmx: pconfig.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,27 @@
++# Id
++
++FILES=warnings.cmi pconfig.cmo
++INCL=
++
++all: $(FILES)
++
++opt: pconfig.cmx
++
++clean:
++ rm -f *.cm[oix] *.o
++
++depend:
++ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend
++
++.SUFFIXES: .mli .cmi .ml .cmo .cmx
++
++.mli.cmi:
++ $(OCAMLN)c $(INCL) -c $<
++
++.ml.cmo:
++ $(OCAMLN)c $(INCL) -c $<
++
++.ml.cmx:
++ $(OCAMLN)opt $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++let ocaml_version = "4.00.2"
++let ocaml_name = "ocaml"
++let ast_impl_magic_number = "Caml1999M015"
++let ast_intf_magic_number = "Caml1999N014"
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++val ocaml_version : string
++val ocaml_name : string
++val ast_impl_magic_number : string
++val ast_intf_magic_number : string
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,75 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1998 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++open Format
++
++type t =
++ | Comment_start (* 1 *)
++ | Comment_not_end (* 2 *)
++ | Deprecated (* 3 *)
++ | Fragile_match of string (* 4 *)
++ | Partial_application (* 5 *)
++ | Labels_omitted (* 6 *)
++ | Method_override of string list (* 7 *)
++ | Partial_match of string (* 8 *)
++ | Non_closed_record_pattern of string (* 9 *)
++ | Statement_type (* 10 *)
++ | Unused_match (* 11 *)
++ | Unused_pat (* 12 *)
++ | Instance_variable_override of string list (* 13 *)
++ | Illegal_backslash (* 14 *)
++ | Implicit_public_methods of string list (* 15 *)
++ | Unerasable_optional_argument (* 16 *)
++ | Undeclared_virtual_method of string (* 17 *)
++ | Not_principal of string (* 18 *)
++ | Without_principality of string (* 19 *)
++ | Unused_argument (* 20 *)
++ | Nonreturning_statement (* 21 *)
++ | Camlp4 of string (* 22 *)
++ | Useless_record_with (* 23 *)
++ | Bad_module_name of string (* 24 *)
++ | All_clauses_guarded (* 25 *)
++ | Unused_var of string (* 26 *)
++ | Unused_var_strict of string (* 27 *)
++ | Wildcard_arg_to_constant_constr (* 28 *)
++ | Eol_in_string (* 29 *)
++ | Duplicate_definitions of string * string * string * string (*30 *)
++ | Multiple_definition of string * string * string (* 31 *)
++ | Unused_value_declaration of string (* 32 *)
++ | Unused_open of string (* 33 *)
++ | Unused_type_declaration of string (* 34 *)
++ | Unused_for_index of string (* 35 *)
++ | Unused_ancestor of string (* 36 *)
++ | Unused_constructor of string * bool * bool (* 37 *)
++ | Unused_exception of string * bool (* 38 *)
++ | Unused_rec_flag (* 39 *)
++;;
++
++val parse_options : bool -> string -> unit;;
++
++val is_active : t -> bool;;
++val is_error : t -> bool;;
++
++val defaults_w : string;;
++val defaults_warn_error : string;;
++
++val print : formatter -> t -> int;;
++ (* returns the number of newlines in the printed string *)
++
++
++exception Errors of int;;
++
++val check_fatal : unit -> unit;;
++
++val help_warnings: unit -> unit
+diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml
+--- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,465 @@
++(* camlp5r pa_macro.cmo *)
++(* File generated by program: edit only if it does not compile. *)
++(* Copyright (c) INRIA 2007-2012 *)
++
++open Parsetree;;
++open Longident;;
++open Asttypes;;
++
++type ('a, 'b) choice =
++ Left of 'a
++ | Right of 'b
++;;
++
++let sys_ocaml_version = Sys.ocaml_version;;
++
++let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) =
++ let loc_at n lnum bolp =
++ {Lexing.pos_fname = if lnum = -1 then "" else fname;
++ Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n}
++ in
++ {Location.loc_start = loc_at bp lnum bolp;
++ Location.loc_end = loc_at ep lnuml bolpl;
++ Location.loc_ghost = bp = 0 && ep = 0}
++;;
++
++let loc_none =
++ let loc =
++ {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
++ Lexing.pos_cnum = -1}
++ in
++ {Location.loc_start = loc; Location.loc_end = loc;
++ Location.loc_ghost = true}
++;;
++
++let mkloc loc txt = {Location.txt = txt; Location.loc = loc};;
++let mknoloc txt = mkloc loc_none txt;;
++
++let ocaml_id_or_li_of_string_list loc sl =
++ let mkli s =
++ let rec loop f =
++ function
++ i :: il -> loop (fun s -> Ldot (f i, s)) il
++ | [] -> f s
++ in
++ loop (fun s -> Lident s)
++ in
++ match List.rev sl with
++ [] -> None
++ | s :: sl -> Some (mkli s (List.rev sl))
++;;
++
++let list_map_check f l =
++ let rec loop rev_l =
++ function
++ x :: l ->
++ begin match f x with
++ Some s -> loop (s :: rev_l) l
++ | None -> None
++ end
++ | [] -> Some (List.rev rev_l)
++ in
++ loop [] l
++;;
++
++let ocaml_value_description t p =
++ {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc}
++;;
++
++let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};;
++
++let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};;
++
++let ocaml_type_declaration params cl tk pf tm loc variance =
++ match list_map_check (fun s_opt -> s_opt) params with
++ Some params ->
++ let params = List.map (fun os -> Some (mknoloc os)) params in
++ Right
++ {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
++ ptype_private = pf; ptype_manifest = tm; ptype_loc = loc;
++ ptype_variance = variance}
++ | None -> Left "no '_' type param in this ocaml version"
++;;
++
++let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});;
++
++let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});;
++
++let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};;
++
++let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);;
++
++let ocaml_pmty_functor sloc s mt1 mt2 =
++ Pmty_functor (mkloc sloc s, mt1, mt2)
++;;
++
++let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);;
++
++let ocaml_pmty_with mt lcl =
++ let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl)
++;;
++
++let ocaml_ptype_abstract = Ptype_abstract;;
++
++let ocaml_ptype_record ltl priv =
++ Ptype_record
++ (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl)
++;;
++
++let ocaml_ptype_variant ctl priv =
++ try
++ let ctl =
++ List.map
++ (fun (c, tl, rto, loc) ->
++ if rto <> None then raise Exit else mknoloc c, tl, None, loc)
++ ctl
++ in
++ Some (Ptype_variant ctl)
++ with Exit -> None
++;;
++
++let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);;
++
++let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);;
++
++let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);;
++
++let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);;
++
++let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));;
++
++let ocaml_ptyp_variant catl clos sl_opt =
++ let catl =
++ List.map
++ (function
++ Left (c, a, tl) -> Rtag (c, a, tl)
++ | Right t -> Rinherit t)
++ catl
++ in
++ Some (Ptyp_variant (catl, clos, sl_opt))
++;;
++
++let ocaml_package_type li ltl =
++ mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl
++;;
++
++let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));;
++
++let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));;
++
++let ocaml_const_nativeint =
++ Some (fun s -> Const_nativeint (Nativeint.of_string s))
++;;
++
++let ocaml_pexp_apply f lel = Pexp_apply (f, lel);;
++
++let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;;
++
++let ocaml_pexp_assert fname loc e = Pexp_assert e;;
++
++let ocaml_pexp_construct li po chk_arity =
++ Pexp_construct (mknoloc li, po, chk_arity)
++;;
++
++let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);;
++
++let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);;
++
++let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);;
++
++let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);;
++
++let ocaml_pexp_ident li = Pexp_ident (mknoloc li);;
++
++let ocaml_pexp_letmodule =
++ Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e))
++;;
++
++let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);;
++
++let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));;
++
++let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);;
++
++let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));;
++
++let ocaml_pexp_override sel =
++ let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel
++;;
++
++let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option =
++ Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));;
++
++let ocaml_pexp_record lel eo =
++ let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in
++ Pexp_record (lel, eo)
++;;
++
++let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);;
++
++let ocaml_pexp_variant =
++ let pexp_variant_pat =
++ function
++ Pexp_variant (lab, eo) -> Some (lab, eo)
++ | _ -> None
++ in
++ let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in
++ Some (pexp_variant_pat, pexp_variant)
++;;
++
++let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);;
++
++let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);;
++
++let ocaml_ppat_construct li li_loc po chk_arity =
++ Ppat_construct (mkloc li_loc li, po, chk_arity)
++;;
++
++let ocaml_ppat_construct_args =
++ function
++ Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity)
++ | _ -> None
++;;
++
++let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);;
++
++let ocaml_ppat_record lpl is_closed =
++ let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in
++ Ppat_record (lpl, (if is_closed then Closed else Open))
++;;
++
++let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));;
++
++let ocaml_ppat_unpack =
++ Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt))
++;;
++
++let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);;
++
++let ocaml_ppat_variant =
++ let ppat_variant_pat =
++ function
++ Ppat_variant (lab, po) -> Some (lab, po)
++ | _ -> None
++ in
++ let ppat_variant (lab, po) = Ppat_variant (lab, po) in
++ Some (ppat_variant_pat, ppat_variant)
++;;
++
++let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);;
++
++let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);;
++
++let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);;
++
++let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);;
++
++let ocaml_psig_open li = Psig_open (mknoloc li);;
++
++let ocaml_psig_recmodule =
++ let f ntl =
++ let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in
++ Psig_recmodule ntl
++ in
++ Some f
++;;
++
++let ocaml_psig_type stl =
++ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl
++;;
++
++let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);;
++
++let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);;
++
++let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);;
++
++let ocaml_pstr_exn_rebind =
++ Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li))
++;;
++
++let ocaml_pstr_include = Some (fun me -> Pstr_include me);;
++
++let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);;
++
++let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);;
++
++let ocaml_pstr_open li = Pstr_open (mknoloc li);;
++
++let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);;
++
++let ocaml_pstr_recmodule =
++ let f nel =
++ Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel)
++ in
++ Some f
++;;
++
++let ocaml_pstr_type stl =
++ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl
++;;
++
++let ocaml_class_infos =
++ Some
++ (fun virt (sl, sloc) name expr loc variance ->
++ let params = List.map (fun s -> mkloc loc s) sl, sloc in
++ {pci_virt = virt; pci_params = params; pci_name = mkloc loc name;
++ pci_expr = expr; pci_loc = loc; pci_variance = variance})
++;;
++
++let ocaml_pmod_ident li = Pmod_ident (mknoloc li);;
++
++let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);;
++
++let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option =
++ Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));;
++
++let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);;
++
++let ocaml_pcf_init = Some (fun e -> Pcf_init e);;
++
++let ocaml_pcf_meth (s, pf, ovf, e, loc) =
++ let pf = if pf then Private else Public in
++ let ovf = if ovf then Override else Fresh in
++ Pcf_meth (mkloc loc s, pf, ovf, e)
++;;
++
++let ocaml_pcf_val (s, mf, ovf, e, loc) =
++ let mf = if mf then Mutable else Immutable in
++ let ovf = if ovf then Override else Fresh in
++ Pcf_val (mkloc loc s, mf, ovf, e)
++;;
++
++let ocaml_pcf_valvirt =
++ let ocaml_pcf (s, mf, t, loc) =
++ let mf = if mf then Mutable else Immutable in
++ Pcf_valvirt (mkloc loc s, mf, t)
++ in
++ Some ocaml_pcf
++;;
++
++let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);;
++
++let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));;
++
++let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));;
++
++let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));;
++
++let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));;
++
++let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));;
++
++let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);;
++
++let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));;
++
++let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);;
++
++let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);;
++
++let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);;
++
++let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));;
++
++let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));;
++
++let ocaml_pcty_signature =
++ let f (t, ctfl) =
++ let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in
++ Pcty_signature cs
++ in
++ Some f
++;;
++
++let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);;
++
++let ocaml_pwith_modsubst =
++ Some (fun loc me -> Pwith_modsubst (mkloc loc me))
++;;
++
++let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);;
++
++let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);;
++
++let module_prefix_can_be_in_first_record_label_only = true;;
++
++let split_or_patterns_with_bindings = false;;
++
++let has_records_with_with = true;;
++
++(* *)
++
++let jocaml_pstr_def : (_ -> _) option = None;;
++
++let jocaml_pexp_def : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_par : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;;
++
++let jocaml_pexp_spawn : (_ -> _) option = None;;
++
++let arg_rest =
++ function
++ Arg.Rest r -> Some r
++ | _ -> None
++;;
++
++let arg_set_string =
++ function
++ Arg.Set_string r -> Some r
++ | _ -> None
++;;
++
++let arg_set_int =
++ function
++ Arg.Set_int r -> Some r
++ | _ -> None
++;;
++
++let arg_set_float =
++ function
++ Arg.Set_float r -> Some r
++ | _ -> None
++;;
++
++let arg_symbol =
++ function
++ Arg.Symbol (s, f) -> Some (s, f)
++ | _ -> None
++;;
++
++let arg_tuple =
++ function
++ Arg.Tuple t -> Some t
++ | _ -> None
++;;
++
++let arg_bool =
++ function
++ Arg.Bool f -> Some f
++ | _ -> None
++;;
++
++let char_escaped = Char.escaped;;
++
++let hashtbl_mem = Hashtbl.mem;;
++
++let list_rev_append = List.rev_append;;
++
++let list_rev_map = List.rev_map;;
++
++let list_sort = List.sort;;
++
++let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;;
++
++let printf_ksprintf = Printf.ksprintf;;
++
++let string_contains = String.contains;;
--- /dev/null
+--- camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli.orig 2013-02-18 15:14:16.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli 2013-02-18 15:14:31.000000000 +0100
+@@ -54,6 +54,10 @@
+ | Unused_constructor of string * bool * bool (* 37 *)
+ | Unused_exception of string * bool (* 38 *)
+ | Unused_rec_flag (* 39 *)
++ | Name_out_of_scope of string list * bool (* 40 *)
++ | Ambiguous_name of string list * string list * bool (* 41 *)
++ | Disambiguated_name of string (* 42 *)
++ | Nonoptional_label of string (* 43 *)
+ ;;
+
+ val parse_options : bool -> string -> unit;;
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oi]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++asttypes.cmi : location.cmi
++location.cmi : ../utils/warnings.cmi
++longident.cmi :
++parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,19 @@
++# Id
++
++FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi
++INCL=-I ../utils
++
++all: $(FILES)
++
++clean:
++ rm -f *.cmi
++
++depend:
++ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend
++
++.SUFFIXES: .mli .cmi
++
++.mli.cmi:
++ $(OCAMLN)c $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,45 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
++
++type constant =
++ Const_int of int
++ | Const_char of char
++ | Const_string of string
++ | Const_float of string
++ | Const_int32 of int32
++ | Const_int64 of int64
++ | Const_nativeint of nativeint
++
++type rec_flag = Nonrecursive | Recursive | Default
++
++type direction_flag = Upto | Downto
++
++type private_flag = Private | Public
++
++type mutable_flag = Immutable | Mutable
++
++type virtual_flag = Virtual | Concrete
++
++type override_flag = Override | Fresh
++
++type closed_flag = Closed | Open
++
++type label = string
++
++type 'a loc = 'a Location.loc = {
++ txt : 'a;
++ loc : Location.t;
++}
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,80 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Source code locations (ranges of positions), used in parsetree. *)
++
++open Format
++
++type t = {
++ loc_start: Lexing.position;
++ loc_end: Lexing.position;
++ loc_ghost: bool;
++}
++
++(* Note on the use of Lexing.position in this module.
++ If [pos_fname = ""], then use [!input_name] instead.
++ If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
++ re-parse the file to get the line and character numbers.
++ Else all fields are correct.
++*)
++
++val none : t
++(** An arbitrary value of type [t]; describes an empty ghost range. *)
++val in_file : string -> t;;
++(** Return an empty ghost range located in a given file. *)
++val init : Lexing.lexbuf -> string -> unit
++(** Set the file name and line number of the [lexbuf] to be the start
++ of the named file. *)
++val curr : Lexing.lexbuf -> t
++(** Get the location of the current token from the [lexbuf]. *)
++
++val symbol_rloc: unit -> t
++val symbol_gloc: unit -> t
++
++(** [rhs_loc n] returns the location of the symbol at position [n], starting
++ at 1, in the current parser rule. *)
++val rhs_loc: int -> t
++
++val input_name: string ref
++val input_lexbuf: Lexing.lexbuf option ref
++
++val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
++val print_loc: formatter -> t -> unit
++val print_error: formatter -> t -> unit
++val print_error_cur_file: formatter -> unit
++val print_warning: t -> formatter -> Warnings.t -> unit
++val prerr_warning: t -> Warnings.t -> unit
++val echo_eof: unit -> unit
++val reset: unit -> unit
++
++val highlight_locations: formatter -> t -> t -> bool
++
++type 'a loc = {
++ txt : 'a;
++ loc : t;
++}
++
++val mknoloc : 'a -> 'a loc
++val mkloc : 'a -> t -> 'a loc
++
++val print: formatter -> t -> unit
++val print_filename: formatter -> string -> unit
++
++val show_filename: string -> string
++ (** In -absname mode, return the absolute path for this filename.
++ Otherwise, returns the filename unchanged. *)
++
++
++val absname: bool ref
++
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,24 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Long identifiers, used in parsetree. *)
++
++type t =
++ Lident of string
++ | Ldot of t * string
++ | Lapply of t * t
++
++val flatten: t -> string list
++val last: t -> string
++val parse: string -> t
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,307 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1996 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Abstract syntax tree produced by parsing *)
++
++open Asttypes
++
++(* Type expressions for the core language *)
++
++type core_type =
++ { ptyp_desc: core_type_desc;
++ ptyp_loc: Location.t }
++
++and core_type_desc =
++ Ptyp_any
++ | Ptyp_var of string
++ | Ptyp_arrow of label * core_type * core_type
++ | Ptyp_tuple of core_type list
++ | Ptyp_constr of Longident.t loc * core_type list
++ | Ptyp_object of core_field_type list
++ | Ptyp_class of Longident.t loc * core_type list * label list
++ | Ptyp_alias of core_type * string
++ | Ptyp_variant of row_field list * bool * label list option
++ | Ptyp_poly of string list * core_type
++ | Ptyp_package of package_type
++
++
++and package_type = Longident.t loc * (Longident.t loc * core_type) list
++
++and core_field_type =
++ { pfield_desc: core_field_desc;
++ pfield_loc: Location.t }
++
++and core_field_desc =
++ Pfield of string * core_type
++ | Pfield_var
++
++and row_field =
++ Rtag of label * bool * core_type list
++ | Rinherit of core_type
++
++(* Type expressions for the class language *)
++
++type 'a class_infos =
++ { pci_virt: virtual_flag;
++ pci_params: string loc list * Location.t;
++ pci_name: string loc;
++ pci_expr: 'a;
++ pci_variance: (bool * bool) list;
++ pci_loc: Location.t }
++
++(* Value expressions for the core language *)
++
++type pattern =
++ { ppat_desc: pattern_desc;
++ ppat_loc: Location.t }
++
++and pattern_desc =
++ Ppat_any
++ | Ppat_var of string loc
++ | Ppat_alias of pattern * string loc
++ | Ppat_constant of constant
++ | Ppat_tuple of pattern list
++ | Ppat_construct of Longident.t loc * pattern option * bool
++ | Ppat_variant of label * pattern option
++ | Ppat_record of (Longident.t loc * pattern) list * closed_flag
++ | Ppat_array of pattern list
++ | Ppat_or of pattern * pattern
++ | Ppat_constraint of pattern * core_type
++ | Ppat_type of Longident.t loc
++ | Ppat_lazy of pattern
++ | Ppat_unpack of string loc
++
++type expression =
++ { pexp_desc: expression_desc;
++ pexp_loc: Location.t }
++
++and expression_desc =
++ Pexp_ident of Longident.t loc
++ | Pexp_constant of constant
++ | Pexp_let of rec_flag * (pattern * expression) list * expression
++ | Pexp_function of label * expression option * (pattern * expression) list
++ | Pexp_apply of expression * (label * expression) list
++ | Pexp_match of expression * (pattern * expression) list
++ | Pexp_try of expression * (pattern * expression) list
++ | Pexp_tuple of expression list
++ | Pexp_construct of Longident.t loc * expression option * bool
++ | Pexp_variant of label * expression option
++ | Pexp_record of (Longident.t loc * expression) list * expression option
++ | Pexp_field of expression * Longident.t loc
++ | Pexp_setfield of expression * Longident.t loc * expression
++ | Pexp_array of expression list
++ | Pexp_ifthenelse of expression * expression * expression option
++ | Pexp_sequence of expression * expression
++ | Pexp_while of expression * expression
++ | Pexp_for of string loc * expression * expression * direction_flag * expression
++ | Pexp_constraint of expression * core_type option * core_type option
++ | Pexp_when of expression * expression
++ | Pexp_send of expression * string
++ | Pexp_new of Longident.t loc
++ | Pexp_setinstvar of string loc * expression
++ | Pexp_override of (string loc * expression) list
++ | Pexp_letmodule of string loc * module_expr * expression
++ | Pexp_assert of expression
++ | Pexp_assertfalse
++ | Pexp_lazy of expression
++ | Pexp_poly of expression * core_type option
++ | Pexp_object of class_structure
++ | Pexp_newtype of string * expression
++ | Pexp_pack of module_expr
++ | Pexp_open of Longident.t loc * expression
++
++(* Value descriptions *)
++
++and value_description =
++ { pval_type: core_type;
++ pval_prim: string list;
++ pval_loc : Location.t
++ }
++
++(* Type declarations *)
++
++and type_declaration =
++ { ptype_params: string loc option list;
++ ptype_cstrs: (core_type * core_type * Location.t) list;
++ ptype_kind: type_kind;
++ ptype_private: private_flag;
++ ptype_manifest: core_type option;
++ ptype_variance: (bool * bool) list;
++ ptype_loc: Location.t }
++
++and type_kind =
++ Ptype_abstract
++ | Ptype_variant of
++ (string loc * core_type list * core_type option * Location.t) list
++ | Ptype_record of
++ (string loc * mutable_flag * core_type * Location.t) list
++
++and exception_declaration = core_type list
++
++(* Type expressions for the class language *)
++
++and class_type =
++ { pcty_desc: class_type_desc;
++ pcty_loc: Location.t }
++
++and class_type_desc =
++ Pcty_constr of Longident.t loc * core_type list
++ | Pcty_signature of class_signature
++ | Pcty_fun of label * core_type * class_type
++
++and class_signature = {
++ pcsig_self : core_type;
++ pcsig_fields : class_type_field list;
++ pcsig_loc : Location.t;
++ }
++
++and class_type_field = {
++ pctf_desc : class_type_field_desc;
++ pctf_loc : Location.t;
++ }
++
++and class_type_field_desc =
++ Pctf_inher of class_type
++ | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
++ | Pctf_virt of (string * private_flag * core_type)
++ | Pctf_meth of (string * private_flag * core_type)
++ | Pctf_cstr of (core_type * core_type)
++
++and class_description = class_type class_infos
++
++and class_type_declaration = class_type class_infos
++
++(* Value expressions for the class language *)
++
++and class_expr =
++ { pcl_desc: class_expr_desc;
++ pcl_loc: Location.t }
++
++and class_expr_desc =
++ Pcl_constr of Longident.t loc * core_type list
++ | Pcl_structure of class_structure
++ | Pcl_fun of label * expression option * pattern * class_expr
++ | Pcl_apply of class_expr * (label * expression) list
++ | Pcl_let of rec_flag * (pattern * expression) list * class_expr
++ | Pcl_constraint of class_expr * class_type
++
++and class_structure = {
++ pcstr_pat : pattern;
++ pcstr_fields : class_field list;
++ }
++
++and class_field = {
++ pcf_desc : class_field_desc;
++ pcf_loc : Location.t;
++ }
++
++and class_field_desc =
++ Pcf_inher of override_flag * class_expr * string option
++ | Pcf_valvirt of (string loc * mutable_flag * core_type)
++ | Pcf_val of (string loc * mutable_flag * override_flag * expression)
++ | Pcf_virt of (string loc * private_flag * core_type)
++ | Pcf_meth of (string loc * private_flag *override_flag * expression)
++ | Pcf_constr of (core_type * core_type)
++ | Pcf_init of expression
++
++and class_declaration = class_expr class_infos
++
++(* Type expressions for the module language *)
++
++and module_type =
++ { pmty_desc: module_type_desc;
++ pmty_loc: Location.t }
++
++and module_type_desc =
++ Pmty_ident of Longident.t loc
++ | Pmty_signature of signature
++ | Pmty_functor of string loc * module_type * module_type
++ | Pmty_with of module_type * (Longident.t loc * with_constraint) list
++ | Pmty_typeof of module_expr
++
++and signature = signature_item list
++
++and signature_item =
++ { psig_desc: signature_item_desc;
++ psig_loc: Location.t }
++
++and signature_item_desc =
++ Psig_value of string loc * value_description
++ | Psig_type of (string loc * type_declaration) list
++ | Psig_exception of string loc * exception_declaration
++ | Psig_module of string loc * module_type
++ | Psig_recmodule of (string loc * module_type) list
++ | Psig_modtype of string loc * modtype_declaration
++ | Psig_open of Longident.t loc
++ | Psig_include of module_type
++ | Psig_class of class_description list
++ | Psig_class_type of class_type_declaration list
++
++and modtype_declaration =
++ Pmodtype_abstract
++ | Pmodtype_manifest of module_type
++
++and with_constraint =
++ Pwith_type of type_declaration
++ | Pwith_module of Longident.t loc
++ | Pwith_typesubst of type_declaration
++ | Pwith_modsubst of Longident.t loc
++
++(* Value expressions for the module language *)
++
++and module_expr =
++ { pmod_desc: module_expr_desc;
++ pmod_loc: Location.t }
++
++and module_expr_desc =
++ Pmod_ident of Longident.t loc
++ | Pmod_structure of structure
++ | Pmod_functor of string loc * module_type * module_expr
++ | Pmod_apply of module_expr * module_expr
++ | Pmod_constraint of module_expr * module_type
++ | Pmod_unpack of expression
++
++and structure = structure_item list
++
++and structure_item =
++ { pstr_desc: structure_item_desc;
++ pstr_loc: Location.t }
++
++and structure_item_desc =
++ Pstr_eval of expression
++ | Pstr_value of rec_flag * (pattern * expression) list
++ | Pstr_primitive of string loc * value_description
++ | Pstr_type of (string loc * type_declaration) list
++ | Pstr_exception of string loc * exception_declaration
++ | Pstr_exn_rebind of string loc * Longident.t loc
++ | Pstr_module of string loc * module_expr
++ | Pstr_recmodule of (string loc * module_type * module_expr) list
++ | Pstr_modtype of string loc * module_type
++ | Pstr_open of Longident.t loc
++ | Pstr_class of class_declaration list
++ | Pstr_class_type of class_type_declaration list
++ | Pstr_include of module_expr
++
++(* Toplevel phrases *)
++
++type toplevel_phrase =
++ Ptop_def of structure
++ | Ptop_dir of string * directive_argument
++
++and directive_argument =
++ Pdir_none
++ | Pdir_string of string
++ | Pdir_int of int
++ | Pdir_ident of Longident.t
++ | Pdir_bool of bool
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oix]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,2 @@
++pconfig.cmo: pconfig.cmi
++pconfig.cmx: pconfig.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,27 @@
++# Id
++
++FILES=warnings.cmi pconfig.cmo
++INCL=
++
++all: $(FILES)
++
++opt: pconfig.cmx
++
++clean:
++ rm -f *.cm[oix] *.o
++
++depend:
++ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend
++
++.SUFFIXES: .mli .cmi .ml .cmo .cmx
++
++.mli.cmi:
++ $(OCAMLN)c $(INCL) -c $<
++
++.ml.cmo:
++ $(OCAMLN)c $(INCL) -c $<
++
++.ml.cmx:
++ $(OCAMLN)opt $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++let ocaml_version = "4.00.2"
++let ocaml_name = "ocaml"
++let ast_impl_magic_number = "Caml1999M015"
++let ast_intf_magic_number = "Caml1999N014"
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++val ocaml_version : string
++val ocaml_name : string
++val ast_impl_magic_number : string
++val ast_intf_magic_number : string
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli 2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,75 @@
++(***********************************************************************)
++(* *)
++(* OCaml *)
++(* *)
++(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *)
++(* *)
++(* Copyright 1998 Institut National de Recherche en Informatique et *)
++(* en Automatique. All rights reserved. This file is distributed *)
++(* under the terms of the Q Public License version 1.0. *)
++(* *)
++(***********************************************************************)
++
++(* Id *)
++
++open Format
++
++type t =
++ | Comment_start (* 1 *)
++ | Comment_not_end (* 2 *)
++ | Deprecated (* 3 *)
++ | Fragile_match of string (* 4 *)
++ | Partial_application (* 5 *)
++ | Labels_omitted (* 6 *)
++ | Method_override of string list (* 7 *)
++ | Partial_match of string (* 8 *)
++ | Non_closed_record_pattern of string (* 9 *)
++ | Statement_type (* 10 *)
++ | Unused_match (* 11 *)
++ | Unused_pat (* 12 *)
++ | Instance_variable_override of string list (* 13 *)
++ | Illegal_backslash (* 14 *)
++ | Implicit_public_methods of string list (* 15 *)
++ | Unerasable_optional_argument (* 16 *)
++ | Undeclared_virtual_method of string (* 17 *)
++ | Not_principal of string (* 18 *)
++ | Without_principality of string (* 19 *)
++ | Unused_argument (* 20 *)
++ | Nonreturning_statement (* 21 *)
++ | Camlp4 of string (* 22 *)
++ | Useless_record_with (* 23 *)
++ | Bad_module_name of string (* 24 *)
++ | All_clauses_guarded (* 25 *)
++ | Unused_var of string (* 26 *)
++ | Unused_var_strict of string (* 27 *)
++ | Wildcard_arg_to_constant_constr (* 28 *)
++ | Eol_in_string (* 29 *)
++ | Duplicate_definitions of string * string * string * string (*30 *)
++ | Multiple_definition of string * string * string (* 31 *)
++ | Unused_value_declaration of string (* 32 *)
++ | Unused_open of string (* 33 *)
++ | Unused_type_declaration of string (* 34 *)
++ | Unused_for_index of string (* 35 *)
++ | Unused_ancestor of string (* 36 *)
++ | Unused_constructor of string * bool * bool (* 37 *)
++ | Unused_exception of string * bool (* 38 *)
++ | Unused_rec_flag (* 39 *)
++;;
++
++val parse_options : bool -> string -> unit;;
++
++val is_active : t -> bool;;
++val is_error : t -> bool;;
++
++val defaults_w : string;;
++val defaults_warn_error : string;;
++
++val print : formatter -> t -> int;;
++ (* returns the number of newlines in the printed string *)
++
++
++exception Errors of int;;
++
++val check_fatal : unit -> unit;;
++
++val help_warnings: unit -> unit
+diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml
+--- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml 1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml 2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,465 @@
++(* camlp5r pa_macro.cmo *)
++(* File generated by program: edit only if it does not compile. *)
++(* Copyright (c) INRIA 2007-2012 *)
++
++open Parsetree;;
++open Longident;;
++open Asttypes;;
++
++type ('a, 'b) choice =
++ Left of 'a
++ | Right of 'b
++;;
++
++let sys_ocaml_version = Sys.ocaml_version;;
++
++let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) =
++ let loc_at n lnum bolp =
++ {Lexing.pos_fname = if lnum = -1 then "" else fname;
++ Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n}
++ in
++ {Location.loc_start = loc_at bp lnum bolp;
++ Location.loc_end = loc_at ep lnuml bolpl;
++ Location.loc_ghost = bp = 0 && ep = 0}
++;;
++
++let loc_none =
++ let loc =
++ {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
++ Lexing.pos_cnum = -1}
++ in
++ {Location.loc_start = loc; Location.loc_end = loc;
++ Location.loc_ghost = true}
++;;
++
++let mkloc loc txt = {Location.txt = txt; Location.loc = loc};;
++let mknoloc txt = mkloc loc_none txt;;
++
++let ocaml_id_or_li_of_string_list loc sl =
++ let mkli s =
++ let rec loop f =
++ function
++ i :: il -> loop (fun s -> Ldot (f i, s)) il
++ | [] -> f s
++ in
++ loop (fun s -> Lident s)
++ in
++ match List.rev sl with
++ [] -> None
++ | s :: sl -> Some (mkli s (List.rev sl))
++;;
++
++let list_map_check f l =
++ let rec loop rev_l =
++ function
++ x :: l ->
++ begin match f x with
++ Some s -> loop (s :: rev_l) l
++ | None -> None
++ end
++ | [] -> Some (List.rev rev_l)
++ in
++ loop [] l
++;;
++
++let ocaml_value_description t p =
++ {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc}
++;;
++
++let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};;
++
++let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};;
++
++let ocaml_type_declaration params cl tk pf tm loc variance =
++ match list_map_check (fun s_opt -> s_opt) params with
++ Some params ->
++ let params = List.map (fun os -> Some (mknoloc os)) params in
++ Right
++ {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
++ ptype_private = pf; ptype_manifest = tm; ptype_loc = loc;
++ ptype_variance = variance}
++ | None -> Left "no '_' type param in this ocaml version"
++;;
++
++let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});;
++
++let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});;
++
++let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};;
++
++let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);;
++
++let ocaml_pmty_functor sloc s mt1 mt2 =
++ Pmty_functor (mkloc sloc s, mt1, mt2)
++;;
++
++let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);;
++
++let ocaml_pmty_with mt lcl =
++ let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl)
++;;
++
++let ocaml_ptype_abstract = Ptype_abstract;;
++
++let ocaml_ptype_record ltl priv =
++ Ptype_record
++ (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl)
++;;
++
++let ocaml_ptype_variant ctl priv =
++ try
++ let ctl =
++ List.map
++ (fun (c, tl, rto, loc) ->
++ if rto <> None then raise Exit else mknoloc c, tl, None, loc)
++ ctl
++ in
++ Some (Ptype_variant ctl)
++ with Exit -> None
++;;
++
++let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);;
++
++let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);;
++
++let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);;
++
++let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);;
++
++let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));;
++
++let ocaml_ptyp_variant catl clos sl_opt =
++ let catl =
++ List.map
++ (function
++ Left (c, a, tl) -> Rtag (c, a, tl)
++ | Right t -> Rinherit t)
++ catl
++ in
++ Some (Ptyp_variant (catl, clos, sl_opt))
++;;
++
++let ocaml_package_type li ltl =
++ mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl
++;;
++
++let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));;
++
++let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));;
++
++let ocaml_const_nativeint =
++ Some (fun s -> Const_nativeint (Nativeint.of_string s))
++;;
++
++let ocaml_pexp_apply f lel = Pexp_apply (f, lel);;
++
++let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;;
++
++let ocaml_pexp_assert fname loc e = Pexp_assert e;;
++
++let ocaml_pexp_construct li po chk_arity =
++ Pexp_construct (mknoloc li, po, chk_arity)
++;;
++
++let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);;
++
++let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);;
++
++let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);;
++
++let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);;
++
++let ocaml_pexp_ident li = Pexp_ident (mknoloc li);;
++
++let ocaml_pexp_letmodule =
++ Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e))
++;;
++
++let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);;
++
++let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));;
++
++let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);;
++
++let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));;
++
++let ocaml_pexp_override sel =
++ let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel
++;;
++
++let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option =
++ Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));;
++
++let ocaml_pexp_record lel eo =
++ let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in
++ Pexp_record (lel, eo)
++;;
++
++let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);;
++
++let ocaml_pexp_variant =
++ let pexp_variant_pat =
++ function
++ Pexp_variant (lab, eo) -> Some (lab, eo)
++ | _ -> None
++ in
++ let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in
++ Some (pexp_variant_pat, pexp_variant)
++;;
++
++let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);;
++
++let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);;
++
++let ocaml_ppat_construct li li_loc po chk_arity =
++ Ppat_construct (mkloc li_loc li, po, chk_arity)
++;;
++
++let ocaml_ppat_construct_args =
++ function
++ Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity)
++ | _ -> None
++;;
++
++let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);;
++
++let ocaml_ppat_record lpl is_closed =
++ let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in
++ Ppat_record (lpl, (if is_closed then Closed else Open))
++;;
++
++let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));;
++
++let ocaml_ppat_unpack =
++ Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt))
++;;
++
++let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);;
++
++let ocaml_ppat_variant =
++ let ppat_variant_pat =
++ function
++ Ppat_variant (lab, po) -> Some (lab, po)
++ | _ -> None
++ in
++ let ppat_variant (lab, po) = Ppat_variant (lab, po) in
++ Some (ppat_variant_pat, ppat_variant)
++;;
++
++let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);;
++
++let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);;
++
++let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);;
++
++let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);;
++
++let ocaml_psig_open li = Psig_open (mknoloc li);;
++
++let ocaml_psig_recmodule =
++ let f ntl =
++ let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in
++ Psig_recmodule ntl
++ in
++ Some f
++;;
++
++let ocaml_psig_type stl =
++ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl
++;;
++
++let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);;
++
++let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);;
++
++let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);;
++
++let ocaml_pstr_exn_rebind =
++ Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li))
++;;
++
++let ocaml_pstr_include = Some (fun me -> Pstr_include me);;
++
++let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);;
++
++let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);;
++
++let ocaml_pstr_open li = Pstr_open (mknoloc li);;
++
++let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);;
++
++let ocaml_pstr_recmodule =
++ let f nel =
++ Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel)
++ in
++ Some f
++;;
++
++let ocaml_pstr_type stl =
++ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl
++;;
++
++let ocaml_class_infos =
++ Some
++ (fun virt (sl, sloc) name expr loc variance ->
++ let params = List.map (fun s -> mkloc loc s) sl, sloc in
++ {pci_virt = virt; pci_params = params; pci_name = mkloc loc name;
++ pci_expr = expr; pci_loc = loc; pci_variance = variance})
++;;
++
++let ocaml_pmod_ident li = Pmod_ident (mknoloc li);;
++
++let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);;
++
++let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option =
++ Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));;
++
++let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);;
++
++let ocaml_pcf_init = Some (fun e -> Pcf_init e);;
++
++let ocaml_pcf_meth (s, pf, ovf, e, loc) =
++ let pf = if pf then Private else Public in
++ let ovf = if ovf then Override else Fresh in
++ Pcf_meth (mkloc loc s, pf, ovf, e)
++;;
++
++let ocaml_pcf_val (s, mf, ovf, e, loc) =
++ let mf = if mf then Mutable else Immutable in
++ let ovf = if ovf then Override else Fresh in
++ Pcf_val (mkloc loc s, mf, ovf, e)
++;;
++
++let ocaml_pcf_valvirt =
++ let ocaml_pcf (s, mf, t, loc) =
++ let mf = if mf then Mutable else Immutable in
++ Pcf_valvirt (mkloc loc s, mf, t)
++ in
++ Some ocaml_pcf
++;;
++
++let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);;
++
++let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));;
++
++let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));;
++
++let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));;
++
++let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));;
++
++let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));;
++
++let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);;
++
++let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));;
++
++let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);;
++
++let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);;
++
++let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);;
++
++let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));;
++
++let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));;
++
++let ocaml_pcty_signature =
++ let f (t, ctfl) =
++ let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in
++ Pcty_signature cs
++ in
++ Some f
++;;
++
++let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);;
++
++let ocaml_pwith_modsubst =
++ Some (fun loc me -> Pwith_modsubst (mkloc loc me))
++;;
++
++let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);;
++
++let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);;
++
++let module_prefix_can_be_in_first_record_label_only = true;;
++
++let split_or_patterns_with_bindings = false;;
++
++let has_records_with_with = true;;
++
++(* *)
++
++let jocaml_pstr_def : (_ -> _) option = None;;
++
++let jocaml_pexp_def : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_par : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;;
++
++let jocaml_pexp_spawn : (_ -> _) option = None;;
++
++let arg_rest =
++ function
++ Arg.Rest r -> Some r
++ | _ -> None
++;;
++
++let arg_set_string =
++ function
++ Arg.Set_string r -> Some r
++ | _ -> None
++;;
++
++let arg_set_int =
++ function
++ Arg.Set_int r -> Some r
++ | _ -> None
++;;
++
++let arg_set_float =
++ function
++ Arg.Set_float r -> Some r
++ | _ -> None
++;;
++
++let arg_symbol =
++ function
++ Arg.Symbol (s, f) -> Some (s, f)
++ | _ -> None
++;;
++
++let arg_tuple =
++ function
++ Arg.Tuple t -> Some t
++ | _ -> None
++;;
++
++let arg_bool =
++ function
++ Arg.Bool f -> Some f
++ | _ -> None
++;;
++
++let char_escaped = Char.escaped;;
++
++let hashtbl_mem = Hashtbl.mem;;
++
++let list_rev_append = List.rev_append;;
++
++let list_rev_map = List.rev_map;;
++
++let list_sort = List.sort;;
++
++let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;;
++
++let printf_ksprintf = Printf.ksprintf;;
++
++let string_contains = String.contains;;
--- /dev/null
+--- camlp5-6.10.orig/ocaml_stuff/4.01.0/utils/warnings.mli 2013-06-19 04:17:42.000000000 +0200
++++ camlp5-6.10/ocaml_stuff/4.01.0/utils/warnings.mli 2013-08-13 16:14:47.000000000 +0200
+@@ -58,6 +58,7 @@
+ | Nonoptional_label of string (* 43 *)
+ | Open_shadow_identifier of string * string (* 44 *)
+ | Open_shadow_label_constructor of string * string (* 45 *)
++ | Bad_env_variable of string * string
+ ;;
+
+ val parse_options : bool -> string -> unit;;
--- /dev/null
+--- camlpdf-0.5.orig/makefile 2010-03-08 17:30:19.000000000 +0100
++++ camlpdf-0.5/makefile 2013-05-30 17:07:12.000000000 +0200
+@@ -42,7 +42,7 @@
+
+ CLIBS = z
+
+-CFLAGS = -m32
++#CFLAGS = -m32
+
+ #Uncomment for debug build
+ #OCAMLNCFLAGS = -g
+@@ -56,6 +56,13 @@
+ #Remove native-code-library if you don't have native compilers
+ all : byte-code-library native-code-library
+
++LIBDIR="`ocamlc -where`"/camlpdf
++.PHONY: install
++install :
++ mkdir -p ${LIBDIR}
++ cp *.mli *.cm[ia] *.cmxa *.a *.so ${LIBDIR}/
++ cp introduction_to_camlpdf.pdf ${LIBDIR}/
++
+ # Predefined generic makefile
+ -include OCamlMakefile
+
--- /dev/null
+--- camlzip-1.04/Makefile 2009-10-20 15:59:55.000000000 +0200
++++ camlzip-1.04/Makefile.new 2009-10-20 16:00:31.000000000 +0200
+@@ -4,10 +4,10 @@
+ ZLIB_LIB=-lz
+
+ # The directory containing the Zlib library (libz.a or libz.so)
+-ZLIB_LIBDIR=/usr/local/lib
++ZLIB_LIBDIR=/opt/local/lib
+
+ # The directory containing the Zlib header file (zlib.h)
+-ZLIB_INCLUDE=/usr/local/include
++ZLIB_INCLUDE=/opt/local/include
+
+ # Where to install the library. By default: sub-directory 'zip' of
+ # OCaml's standard library directory.
+--- /dev/null 2009-10-20 16:35:40.000000000 +0200
++++ camlzip-1.04/META 2009-10-20 16:37:31.000000000 +0200
+@@ -0,0 +1,6 @@
++name = "camlzip"
++version = "1.04"
++description = "compression library"
++archive(byte) = "zip.cma"
++archive(native) = "zip.cmxa"
++directory = "+zip"
+--- camlzip-1.04/Makefile.orig 2011-07-04 18:09:00.000000000 +0200
++++ camlzip-1.04/Makefile 2011-07-04 18:10:09.000000000 +0200
+@@ -56,7 +56,8 @@
+
+ install:
+ mkdir -p $(INSTALLDIR)
+- cp zip.cma zip.cmi gzip.cmi zip.mli gzip.mli libcamlzip.a $(INSTALLDIR)
++ cp zip.cma zip.cmi gzip.cmi zlib.cmi zip.mli gzip.mli zlib.mli \
++ libcamlzip.a $(INSTALLDIR)
+ if test -f dllcamlzip.so; then \
+ cp dllcamlzip.so $(INSTALLDIR); \
+ ldconf=`$(OCAMLC) -where`/ld.conf; \
+@@ -66,7 +67,7 @@
+ fi
+
+ installopt:
+- cp zip.cmxa zip.a zip.cmx gzip.cmx $(INSTALLDIR)
++ cp zip.cmxa zip.a zip.cmx gzip.cmx zlib.cmx $(INSTALLDIR)
+
+ depend:
+ gcc -MM -I$(ZLIB_INCLUDE) *.c > .depend
--- /dev/null
+--- coq-8.3pl4.orig/configure 2011-12-19 22:57:30.000000000 +0100
++++ coq-8.3pl4/configure 2012-03-16 11:44:55.000000000 +0100
+@@ -444,7 +444,7 @@
+
+ if [ "$coq_debug_flag" = "-g" ]; then
+ case $CAMLTAG in
+- OCAML31*)
++ OCAML31*|OCAML4*)
+ # Compilation debug flag
+ coq_debug_flag_opt="-g"
+ ;;
+@@ -494,7 +494,7 @@
+ camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'`
+ else
+ case $CAMLTAG in
+- OCAML31*)
++ OCAML31*|OCAML4*)
+ if [ -x "${CAMLLIB}/camlp5" ]; then
+ CAMLP4LIB=+camlp5
+ elif [ -x "${CAMLLIB}/site-lib/camlp5" ]; then
+@@ -538,7 +538,7 @@
+ CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if [ "`uname -s`" = "Darwin" -a "$ARCH" = "i386" ]; then
+ case $CAMLOPTVERSION in
+- 3.09.3|3.1?*) ;;
++ 3.09.3|3.1?*|4.*) ;;
+ *) echo "Native compilation on MacOS X Pentium requires Objective-Caml >= 3.09.3,"
+ best_compiler=byte
+ echo "only the bytecode version of Coq will be available."
+--- coq-8.3pl4/scripts/coqmktop.ml.orig 2012-05-26 21:32:12.000000000 +0200
++++ coq-8.3pl4/scripts/coqmktop.ml 2012-05-26 21:36:35.000000000 +0200
+@@ -63,6 +63,7 @@
+ (src_dirs ())
+ (["-I"; "\"" ^ camlp4lib ^ "\""] @
+ ["-I"; "\"" ^ coqlib ^ "\""] @
++ ["-I"; "+compiler-libs"] @
+ (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
+
+ (* Transform bytecode object file names in native object file names *)
+@@ -274,7 +275,7 @@
+ ocamloptexec^" -linkall"
+ end else
+ (* bytecode (we shunt ocamlmktop script which fails on win32) *)
+- let ocamlmktoplib = " toplevellib.cma" in
++ let ocamlmktoplib = " ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma" in
+ let ocamlcexec = Filename.concat camlbin "ocamlc" in
+ let ocamlccustom = Printf.sprintf "%s %s -linkall "
+ ocamlcexec Coq_config.coqrunbyteflags in
+--- coq-8.3pl4/configure.orig 2012-07-18 11:31:08.353180800 +0200
++++ coq-8.3pl4/configure 2012-07-18 11:31:10.346046400 +0200
+@@ -272,7 +272,7 @@
+ no)
+ # First we test if we are running a Cygwin system
+ if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then
+- ARCH="win32"
++ ARCH=`uname -s`
+ else
+ # If not, we determine the architecture
+ if test -x /bin/arch ; then
--- /dev/null
+--- core-109.37.00.orig/lib/core_unix.ml 2013-08-06 21:52:16.000000000 +0200
++++ core-109.37.00/lib/core_unix.ml 2013-08-13 15:25:11.000000000 +0200
+@@ -890,6 +890,7 @@
+ | O_SYNC
+ | O_RSYNC
+ | O_SHARE_DELETE
++| O_CLOEXEC
+ with sexp
+
+ type file_perm = int with of_sexp
+--- core-109.37.00.orig/lib/core_unix.mli 2013-08-06 21:52:16.000000000 +0200
++++ core-109.37.00/lib/core_unix.mli 2013-08-13 15:25:32.000000000 +0200
+@@ -305,6 +305,7 @@
+ | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *)
+ | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
+ | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *)
++ | O_CLOEXEC
+ with sexp
+
+ (** The type of file access rights. *)
--- /dev/null
+--- core-suite-108.00.01.orig/sexplib-108.00.01/top/install_printers.ml 2012-05-14 20:53:09.000000000 +0200
++++ core-suite-108.00.01/sexplib-108.00.01/top/install_printers.ml 2012-07-12 17:33:45.000000000 +0200
+@@ -3,8 +3,11 @@
+ let eval_string
+ ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str =
+ let lexbuf = Lexing.from_string str in
++assert false
++(*
+ let phrase = !Toploop.parse_toplevel_phrase lexbuf in
+ Toploop.execute_phrase print_outcome err_formatter phrase
++*)
+
+ let rec install_printers = function
+ | [] -> true
+--- core-suite-108.00.01.orig/core-108.00.01/lib/core_unix.mli 2012-05-25 23:10:12.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/lib/core_unix.mli 2012-07-12 17:39:29.000000000 +0200
+@@ -296,6 +296,7 @@
+ | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *)
+ | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *)
+ | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
++ | O_SHARE_DELETE
+ with sexp
+
+ (** The type of file access rights. *)
+--- core-suite-108.00.01.orig/core-108.00.01/lib/core_unix.ml 2012-05-25 23:10:12.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/lib/core_unix.ml 2012-07-12 17:44:04.000000000 +0200
+@@ -804,6 +804,7 @@
+ | O_DSYNC
+ | O_SYNC
+ | O_RSYNC
++| O_SHARE_DELETE
+ with sexp
+
+ type file_perm = int with of_sexp
+--- core-suite-108.00.01.orig/core-108.00.01/top/install_printers.ml 2012-05-17 16:50:03.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/top/install_printers.ml 2012-07-12 17:48:36.000000000 +0200
+@@ -5,8 +5,11 @@
+ let eval_string
+ ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str =
+ let lexbuf = Lexing.from_string str in
++assert false
++(*
+ let phrase = !Toploop.parse_toplevel_phrase lexbuf in
+ Toploop.execute_phrase print_outcome err_formatter phrase
++*)
+
+ let rec install_printers = function
+ | [] -> true
+--- core-suite-108.00.01.orig/async-108.00.01/myocamlbuild.ml 2012-05-26 00:48:10.000000000 +0200
++++ core-suite-108.00.01/async-108.00.01/myocamlbuild.ml 2012-07-12 17:59:01.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/async_core-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/async_core-108.00.01/myocamlbuild.ml 2012-07-12 17:58:57.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/async_extra-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/async_extra-108.00.01/myocamlbuild.ml 2012-07-12 17:58:53.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/async_unix-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/async_unix-108.00.01/myocamlbuild.ml 2012-07-12 17:58:48.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/bin_prot-108.00.01/myocamlbuild.ml 2012-05-26 00:48:07.000000000 +0200
++++ core-suite-108.00.01/bin_prot-108.00.01/myocamlbuild.ml 2012-07-12 17:15:41.000000000 +0200
+@@ -636,7 +636,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ (* We probably will want to set this up in the `configure` script at some
+--- core-suite-108.00.01.orig/comparelib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/comparelib-108.00.01/myocamlbuild.ml 2012-07-12 17:58:40.000000000 +0200
+@@ -631,7 +631,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/core-108.00.01/myocamlbuild.ml 2012-05-26 00:48:08.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/myocamlbuild.ml 2012-07-12 17:35:18.000000000 +0200
+@@ -643,7 +643,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/core_extended-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/core_extended-108.00.01/myocamlbuild.ml 2012-07-12 17:51:57.000000000 +0200
+@@ -645,7 +645,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/fieldslib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/fieldslib-108.00.01/myocamlbuild.ml 2012-07-12 17:07:50.000000000 +0200
+@@ -631,7 +631,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/pa_ounit-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/pa_ounit-108.00.01/myocamlbuild.ml 2012-07-12 17:13:58.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/pipebang-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/pipebang-108.00.01/myocamlbuild.ml 2012-07-12 17:58:22.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/sexplib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:07.000000000 +0200
++++ core-suite-108.00.01/sexplib-108.00.01/myocamlbuild.ml 2012-07-12 17:24:42.000000000 +0200
+@@ -635,7 +635,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence"])
+ ;;
+
+ Ocamlbuild_plugin.dispatch
+--- core-suite-108.00.01.orig/type_conv-108.00.01/myocamlbuild.ml 2012-05-26 00:48:05.000000000 +0200
++++ core-suite-108.00.01/type_conv-108.00.01/myocamlbuild.ml 2012-07-12 17:05:31.000000000 +0200
+@@ -630,7 +630,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/typehashlib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/typehashlib-108.00.01/myocamlbuild.ml 2012-07-12 17:58:06.000000000 +0200
+@@ -631,7 +631,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
+--- core-suite-108.00.01.orig/variantslib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/variantslib-108.00.01/myocamlbuild.ml 2012-07-12 17:11:51.000000000 +0200
+@@ -631,7 +631,7 @@
+ List.concat (List.map f flags)
+ in
+ flag ["compile"; "c"] (S cflags);
+- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+
+ let dispatch = function
--- /dev/null
+--- extlib-1.5.2.orig/extHashtbl.ml 2011-08-06 16:56:39.000000000 +0200
++++ extlib-1.5.2/extHashtbl.ml 2012-01-12 19:48:28.000000000 +0100
+@@ -32,6 +32,7 @@
+ }
+
+ include Hashtbl
++ let create n = Hashtbl.create (* no seed *) n
+
+ external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity"
+ external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity"
--- /dev/null
+diff -r -u frama-c-Nitrogen-20111001.orig/src/type/datatype.mli frama-c-Nitrogen-20111001/src/type/datatype.mli
+--- frama-c-Nitrogen-20111001.orig/src/type/datatype.mli 2011-10-10 10:38:09.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/type/datatype.mli 2012-01-05 18:35:45.000000000 +0100
+@@ -249,10 +249,27 @@
+
+ end
+
++module type Hashtbl_S = sig
++ type key
++ type 'a t
++ val create : int -> 'a t
++ val clear : 'a t -> unit
++ val copy : 'a t -> 'a t
++ val add : 'a t -> key -> 'a -> unit
++ val remove : 'a t -> key -> unit
++ val find : 'a t -> key -> 'a
++ val find_all : 'a t -> key -> 'a list
++ val replace : 'a t -> key -> 'a -> unit
++ val mem : 'a t -> key -> bool
++ val iter : (key -> 'a -> unit) -> 'a t -> unit
++ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
++ val length : 'a t -> int
++end
++
+ (** A standard OCaml hashtbl signature extended with datatype operations. *)
+ module type Hashtbl = sig
+
+- include Hashtbl.S
++ include Hashtbl_S
+
+ val memo: 'a t -> key -> (key -> 'a) -> 'a
+ (** [memo tbl k f] returns the binding of [k] in [tbl]. If there is
+@@ -468,7 +485,7 @@
+ module Map(M: Map_common_interface.S)(Key: S with type t = M.key)(Info: Functor_info) :
+ Map with type 'a t = 'a M.t and type key = M.key and module Key = Key
+
+-module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info):
++module Hashtbl(H: Hashtbl_S)(Key: S with type t = H.key)(Info : Functor_info):
+ Hashtbl with type 'a t = 'a H.t and type key = H.key and module Key = Key
+
+ module type Sub_caml_weak_hashtbl = sig
+diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/LogicId.mli frama-c-Nitrogen-20111001/src/wp/LogicId.mli
+--- frama-c-Nitrogen-20111001.orig/src/wp/LogicId.mli 2011-10-10 10:38:21.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/wp/LogicId.mli 2012-01-05 18:38:36.000000000 +0100
+@@ -40,7 +40,7 @@
+
+ module Iset : Set.S with type elt = t
+ module Imap : Map.S with type key = t
+-module Ihmap : Hashtbl.S with type key = t
++module Ihmap : Datatype.Hashtbl_S with type key = t
+
+ (** {3 Name Spaces} *)
+
+diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/fol_formula.ml frama-c-Nitrogen-20111001/src/wp/fol_formula.ml
+--- frama-c-Nitrogen-20111001.orig/src/wp/fol_formula.ml 2011-10-10 10:38:21.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/wp/fol_formula.ml 2012-01-05 18:31:40.000000000 +0100
+@@ -389,7 +389,7 @@
+ module type Identifiable =
+ sig
+ type t
+- module H : Hashtbl.S
++ module H : Datatype.Hashtbl_S
+ val index : t -> H.key
+ val prefix : string
+ val basename : t -> string
+diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/formula.mli frama-c-Nitrogen-20111001/src/wp/formula.mli
+--- frama-c-Nitrogen-20111001.orig/src/wp/formula.mli 2011-10-10 10:38:21.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/wp/formula.mli 2012-01-05 18:38:28.000000000 +0100
+@@ -147,7 +147,7 @@
+ module type Identifiable =
+ sig
+ type t
+- module H : Hashtbl.S
++ module H : Datatype.Hashtbl_S
+ val index : t -> H.key
+ val prefix : string
+ val basename : t -> string
+--- frama-c-Nitrogen-20111001.orig/src/type/datatype.ml 2011-10-10 10:38:09.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/type/datatype.ml 2012-01-05 18:46:38.000000000 +0100
+@@ -306,8 +306,26 @@
+ module Make(Data: S) : S with type t = Data.t t
+ end
+
++module type Hashtbl_S =
++ sig
++ type key
++ type 'a t
++ val create : int -> 'a t
++ val clear : 'a t -> unit
++ val copy : 'a t -> 'a t
++ val add : 'a t -> key -> 'a -> unit
++ val remove : 'a t -> key -> unit
++ val find : 'a t -> key -> 'a
++ val find_all : 'a t -> key -> 'a list
++ val replace : 'a t -> key -> 'a -> unit
++ val mem : 'a t -> key -> bool
++ val iter : (key -> 'a -> unit) -> 'a t -> unit
++ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
++ val length : 'a t -> int
++ end
++
+ module type Hashtbl = sig
+- include Hashtbl.S
++ include Hashtbl_S
+ val memo: 'a t -> key -> (key -> 'a) -> 'a
+ module Key: S with type t = key
+ module Make(Data: S) : S with type t = Data.t t
+@@ -970,7 +988,7 @@
+ module Initial_caml_hashtbl = Hashtbl
+
+ (* ocaml functors are generative *)
+-module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info) =
++module Hashtbl(H: Hashtbl_S)(Key: S with type t = H.key)(Info : Functor_info) =
+ struct
+
+ let () = check Key.equal "equal" Key.name Info.module_name
+--- frama-c-Nitrogen-20111001/configure.orig 2012-03-12 16:14:45.000000000 +0100
++++ frama-c-Nitrogen-20111001/configure 2012-03-12 16:15:06.000000000 +0100
+@@ -2675,6 +2675,7 @@
+ ;;
+ 3.10*) echo "${ECHO_T}good!";;
+ 3.1*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";;
++ 4.0*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";;
+ *) echo "${ECHO_T}Incompatible version!"; exit 2;;
+ esac
+
--- /dev/null
+--- frama-c-Oxygen-20120901.orig/src/type/datatype.ml 2012-09-19 13:55:23.000000000 +0200
++++ frama-c-Oxygen-20120901/src/type/datatype.ml 2013-02-19 16:36:36.000000000 +0100
+@@ -285,8 +285,37 @@
+
+ end
+
++module type Set_S = sig
++ type elt
++ type t
++ val empty: t
++ val is_empty: t -> bool
++ val mem: elt -> t -> bool
++ val add: elt -> t -> t
++ val singleton: elt -> t
++ val remove: elt -> t -> t
++ val union: t -> t -> t
++ val inter: t -> t -> t
++ val diff: t -> t -> t
++ val compare: t -> t -> int
++ val equal: t -> t -> bool
++ val subset: t -> t -> bool
++ val iter: (elt -> unit) -> t -> unit
++ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++ val for_all: (elt -> bool) -> t -> bool
++ val exists: (elt -> bool) -> t -> bool
++ val filter: (elt -> bool) -> t -> t
++ val partition: (elt -> bool) -> t -> t * t
++ val cardinal: t -> int
++ val elements: t -> elt list
++ val min_elt: t -> elt
++ val max_elt: t -> elt
++ val choose: t -> elt
++ val split: elt -> t -> t * bool * t
++end
++
+ module type Set = sig
+- include Set.S
++ include Set_S
+ val ty: t Type.t
+ val name: string
+ val descr: t Descr.t
+@@ -1093,7 +1122,7 @@
+ module Initial_caml_set = Set
+
+ (* ocaml functors are generative *)
+-module Set(S: Set.S)(E: S with type t = S.elt)(Info: Functor_info) = struct
++module Set(S: Set_S)(E: S with type t = S.elt)(Info: Functor_info) = struct
+
+ let () = check E.equal "equal" E.name Info.module_name
+ let () = check E.compare "compare" E.name Info.module_name
+--- frama-c-Oxygen-20120901.orig/src/type/datatype.mli 2012-09-19 13:55:23.000000000 +0200
++++ frama-c-Oxygen-20120901/src/type/datatype.mli 2013-02-19 16:36:29.000000000 +0100
+@@ -230,9 +230,38 @@
+ defining by applying the functor. *)
+ end
+
++module type Set_S = sig
++ type elt
++ type t
++ val empty: t
++ val is_empty: t -> bool
++ val mem: elt -> t -> bool
++ val add: elt -> t -> t
++ val singleton: elt -> t
++ val remove: elt -> t -> t
++ val union: t -> t -> t
++ val inter: t -> t -> t
++ val diff: t -> t -> t
++ val compare: t -> t -> int
++ val equal: t -> t -> bool
++ val subset: t -> t -> bool
++ val iter: (elt -> unit) -> t -> unit
++ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++ val for_all: (elt -> bool) -> t -> bool
++ val exists: (elt -> bool) -> t -> bool
++ val filter: (elt -> bool) -> t -> t
++ val partition: (elt -> bool) -> t -> t * t
++ val cardinal: t -> int
++ val elements: t -> elt list
++ val min_elt: t -> elt
++ val max_elt: t -> elt
++ val choose: t -> elt
++ val split: elt -> t -> t * bool * t
++end
++
+ (** A standard OCaml set signature extended with datatype operations. *)
+ module type Set = sig
+- include Set.S
++ include Set_S
+ val ty: t Type.t
+ val name: string
+ val descr: t Descr.t
+@@ -602,7 +631,7 @@
+ 'e Type.t ->
+ ('a -> 'b -> 'c -> 'd -> 'e) Type.t
+
+-module Set(S: Set.S)(E: S with type t = S.elt)(Info : Functor_info):
++module Set(S: Set_S)(E: S with type t = S.elt)(Info : Functor_info):
+ Set with type t = S.t and type elt = E.t
+
+ module Map
+--- frama-c-Oxygen-20120901.orig/src/wp/qed/src/idxset.ml 2012-09-19 13:55:28.000000000 +0200
++++ frama-c-Oxygen-20120901/src/wp/qed/src/idxset.ml 2013-02-19 16:45:08.000000000 +0100
+@@ -20,9 +20,38 @@
+ (* *)
+ (**************************************************************************)
+
++module type Set_S = sig
++ type elt
++ type t
++ val empty: t
++ val is_empty: t -> bool
++ val mem: elt -> t -> bool
++ val add: elt -> t -> t
++ val singleton: elt -> t
++ val remove: elt -> t -> t
++ val union: t -> t -> t
++ val inter: t -> t -> t
++ val diff: t -> t -> t
++ val compare: t -> t -> int
++ val equal: t -> t -> bool
++ val subset: t -> t -> bool
++ val iter: (elt -> unit) -> t -> unit
++ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++ val for_all: (elt -> bool) -> t -> bool
++ val exists: (elt -> bool) -> t -> bool
++ val filter: (elt -> bool) -> t -> t
++ val partition: (elt -> bool) -> t -> t * t
++ val cardinal: t -> int
++ val elements: t -> elt list
++ val min_elt: t -> elt
++ val max_elt: t -> elt
++ val choose: t -> elt
++ val split: elt -> t -> t * bool * t
++end
++
+ module type S =
+ sig
+- include Set.S
++ include Set_S
+ val map : (elt -> elt) -> t -> t
+ val intersect : t -> t -> bool
+ end
+--- frama-c-Oxygen-20120901.orig/src/wp/qed/src/idxset.mli 2012-09-19 13:55:28.000000000 +0200
++++ frama-c-Oxygen-20120901/src/wp/qed/src/idxset.mli 2013-02-19 16:45:19.000000000 +0100
+@@ -22,9 +22,38 @@
+
+ (** Set of indexed elements implemented as Patricia sets. *)
+
++module type Set_S = sig
++ type elt
++ type t
++ val empty: t
++ val is_empty: t -> bool
++ val mem: elt -> t -> bool
++ val add: elt -> t -> t
++ val singleton: elt -> t
++ val remove: elt -> t -> t
++ val union: t -> t -> t
++ val inter: t -> t -> t
++ val diff: t -> t -> t
++ val compare: t -> t -> int
++ val equal: t -> t -> bool
++ val subset: t -> t -> bool
++ val iter: (elt -> unit) -> t -> unit
++ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++ val for_all: (elt -> bool) -> t -> bool
++ val exists: (elt -> bool) -> t -> bool
++ val filter: (elt -> bool) -> t -> t
++ val partition: (elt -> bool) -> t -> t * t
++ val cardinal: t -> int
++ val elements: t -> elt list
++ val min_elt: t -> elt
++ val max_elt: t -> elt
++ val choose: t -> elt
++ val split: elt -> t -> t * bool * t
++end
++
+ module type S =
+ sig
+- include Set.S
++ include Set_S
+ val map : (elt -> elt) -> t -> t
+ val intersect : t -> t -> bool
+ end
--- /dev/null
+diff -r -u hevea-1.10 2/hevea.ml hevea-1.10/hevea.ml
+--- hevea-1.10 2/hevea.ml 2007-02-09 15:44:28.000000000 +0100
++++ hevea-1.10/hevea.ml 2009-08-27 17:51:55.000000000 +0200
+@@ -237,6 +237,7 @@
+ *)
+ end ;
+ let _ = finalize false in
++ begin try Sys.remove Parse_opts.name_out with _ -> () end;
+ prerr_endline "Adios" ;
+ exit 2
+ ;;
+--- hevea-1.10/Makefile.orig 2009-10-28 12:18:16.000000000 +0100
++++ hevea-1.10/Makefile 2009-10-28 12:18:00.000000000 +0100
+@@ -48,7 +48,7 @@
+ all-make: $(TARGET)-make
+
+ install: config.sh
+- ./install.sh $(TARGET)
++ LIBDIR=${LIBDIR} LATEXLIBDIR=${LATEXLIBDIR} ./install.sh $(TARGET)
+
+ byte: ocb-byte
+ opt: ocb-opt
--- /dev/null
+--- kaputt-1.2/src/syntax/kaputt_pp.ml.orig 2012-12-19 16:46:36.000000000 +0100
++++ kaputt-1.2/src/syntax/kaputt_pp.ml 2012-12-19 16:46:59.000000000 +0100
+@@ -54,6 +54,8 @@
+ let temp_name, temp_chan = Filename.open_temp_file "kaputt" ".ml" in
+ let source_chan = open_in args.(len - 3) in
+ let test_chan = open_in test_file in
++ let directive = Printf.sprintf "# 1 %S\n" args.(len - 3) in
++ output_string temp_chan directive;
+ copy source_chan temp_chan;
+ let directive = Printf.sprintf "# 1 %S\n" test_file in
+ output_string temp_chan directive;
+--- kaputt-1.2/src/syntax/kaputt_pp.ml.orig 2013-01-08 17:05:01.000000000 +0100
++++ kaputt-1.2/src/syntax/kaputt_pp.ml 2013-01-08 17:05:46.000000000 +0100
+@@ -28,8 +28,7 @@
+ Buffer.add_string buff (quote args.(i));
+ Buffer.add_char buff ' ';
+ done;
+- let code = Sys.command (Buffer.contents buff) in
+- ignore (exit code)
++ Sys.command (Buffer.contents buff)
+
+ let copy from_chan to_chan =
+ try
+@@ -64,9 +63,11 @@
+ close_in_noerr test_chan;
+ close_out_noerr temp_chan;
+ args.(len - 3) <- temp_name;
+- call args
++ let code = call args in
++ (try Sys.remove temp_name with _ -> ());
++ ignore (exit code)
+ end else begin
+- call args
++ ignore (exit (call args))
+ end
+ else begin
+ Printf.eprintf "Error: invalid command-line\n";
--- /dev/null
+--- lablgtk-2.14.2/src/Makefile.orig 2012-07-31 17:37:12.000000000 +0200
++++ lablgtk-2.14.2/src/Makefile 2012-07-31 17:37:17.000000000 +0200
+@@ -191,7 +191,7 @@
+ .ml4.cmo:
+ $(CAMLC) -c -pp "$(CAMLP4O) -impl" -impl $<
+ .cmxa.cmxs:
+- $(CAMLOPT) -verbose -o $@ -shared -linkall -I . \
++ $(CAMLOPT) -o $@ -shared -linkall -I . \
+ -ccopt '$(filter -L%, $(DYNLINKLIBS))' $<
+
+ #.ml4.ml:
--- /dev/null
+--- lablgtk-2.16.0.orig/src/gMenu.ml 2012-08-23 12:37:48.000000000 +0200
++++ lablgtk-2.16.0/src/gMenu.ml 2013-02-18 20:12:27.000000000 +0100
+@@ -87,7 +87,7 @@
+
+ class menu_item_skel = [menu_item] pre_menu_item_skel
+
+-let pack_item self ~packing ~show =
++let pack_item self ?packing ?show =
+ may packing ~f:(fun f -> (f (self :> menu_item) : unit));
+ if show <> Some false then self#misc#show ();
+ self
+--- lablgtk-2.16.0.orig/src/gFile.ml 2012-08-23 12:37:48.000000000 +0200
++++ lablgtk-2.16.0/src/gFile.ml 2013-02-18 20:13:37.000000000 +0100
+@@ -179,7 +179,7 @@
+ FileChooser.P.file_system_backend backend
+ [ Gobject.param FileChooser.P.action action ]) in
+ let o = new chooser_widget w in
+- GObj.pack_return o ?packing ?show
++ GObj.pack_return o ~packing ~show
+
+ class chooser_button_signals obj = object
+ inherit GContainer.container_signals_impl obj
--- /dev/null
+--- lablgtkextras-1.1.orig/checkocaml.ml 2012-04-13 16:51:37.000000000 +0200
++++ lablgtkextras-1.1/checkocaml.ml 2012-05-25 16:23:36.000000000 +0200
+@@ -885,7 +885,7 @@
+ let _ = !print "\n### checking required tools and libraries ###\n"
+
+ let () = check_ocamlfind_package conf "config-file";;
+-let () = check_ocamlfind_package conf "lablgtk2.sourceview2";;
++let () = check_ocamlfind_package conf "lablgtk2";;
+ let () = check_ocamlfind_package conf ~min_version: [1;1] "xmlm";;
+
+ let _ = !print "\n###\n"
+--- lablgtkextras-1.1.orig/src/Makefile 2012-04-13 16:51:37.000000000 +0200
++++ lablgtkextras-1.1/src/Makefile 2012-05-25 16:27:58.000000000 +0200
+@@ -26,7 +26,7 @@
+
+ include ../master.Makefile
+
+-PACKAGES=config-file,lablgtk2.sourceview2,xmlm
++PACKAGES=config-file,lablgtk2,xmlm
+ OF_FLAGS= -package $(PACKAGES)
+
+ COMPFLAGS=-annot -g -warn-error A
--- /dev/null
+--- lablgtkextras-1.3/src/Makefile.orig 2013-05-29 14:21:34.000000000 +0200
++++ lablgtkextras-1.3/src/Makefile 2013-05-29 14:21:52.000000000 +0200
+@@ -29,7 +29,7 @@
+ PACKAGES=config-file,lablgtk2.sourceview2,xmlm
+ OF_FLAGS= -package $(PACKAGES)
+
+-COMPFLAGS=-annot -g -warn-error A
++COMPFLAGS=-annot -g -warn-error a
+
+ GELIB_CMOFILES= \
+ gtke_version.cmo \
--- /dev/null
+--- lwt-2.4.0.orig/src/unix/lwt_unix.ml 2012-07-19 13:35:56.000000000 +0200
++++ lwt-2.4.0/src/unix/lwt_unix.ml 2013-08-13 15:46:12.000000000 +0200
+@@ -596,6 +596,9 @@
+ #if ocaml_version >= (3, 13)
+ | O_SHARE_DELETE
+ #endif
++#if ocaml_version >= (4, 01)
++ | O_CLOEXEC
++#endif
+
+ #if windows
+
+--- lwt-2.4.0.orig/src/unix/lwt_unix.mli 2012-07-19 13:35:56.000000000 +0200
++++ lwt-2.4.0/src/unix/lwt_unix.mli 2013-08-13 15:46:18.000000000 +0200
+@@ -315,6 +315,9 @@
+ #if ocaml_version >= (3, 13)
+ | O_SHARE_DELETE
+ #endif
++#if ocaml_version >= (4, 01)
++ | O_CLOEXEC
++#endif
+
+ val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t
+ (** Wrapper for [Unix.openfile]. *)
--- /dev/null
+--- menhir-20120123/Makefile.arch.orig 2012-09-28 19:03:09.673811200 +0200
++++ menhir-20120123/Makefile.arch 2012-09-28 19:07:38.680344000 +0200
+@@ -1,7 +1,7 @@
+ # If ocaml reports that Sys.os_type is Unix, we assume Unix, otherwise
+ # we assume Windows.
+
+-ifeq "$(shell rm -f ./o.ml && echo print_endline Sys.os_type > ./o.ml && ocaml ./o.ml && rm -f ./o.ml)" "Unix"
++ifneq "$(shell rm -f ./o.ml && echo print_endline Sys.os_type > ./o.ml && ocaml ./o.ml && rm -f ./o.ml)" "Win32"
+ MENHIREXE := menhir
+ OBJ := o
+ else
--- /dev/null
+--- mldonkey-3.1.2.orig/config/configure 2011-08-08 07:11:57.000000000 +0200
++++ mldonkey-3.1.2/config/configure 2012-03-13 12:52:40.000000000 +0100
+@@ -4870,7 +4870,7 @@
+ else
+ OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ case "$OCAMLVERSION" in
+- "$REQUIRED_OCAML"*|3.12.*|3.11.*|3.10.1*|3.10.2*) ;;
++ "$REQUIRED_OCAML"*|4.*|3.1[23].*|3.11.*|3.10.1*|3.10.2*) ;;
+ *)
+ echo "Need build"
+ BUILD_OCAML=yes
+@@ -5402,7 +5402,7 @@
+
+ # force usage of supported Ocaml versions
+ case "$OCAMLVERSION" in
+- 3.10.1*|3.10.2*|3.1*) ;;
++ 3.10.1*|3.10.2*|3.1*|4.*) ;;
+ *)
+ if test "$REQUIRED_OCAML" != "SVN" ; then
+ echo "******** Version $REQUIRED_OCAML of Objective-Caml is required *********" 1>&2;
+--- mldonkey-3.1.2.orig/Makefile 2012-05-16 11:56:34.000000000 +0200
++++ mldonkey-3.1.2/Makefile 2012-05-25 19:24:15.000000000 +0200
+@@ -5447,7 +5449,7 @@
+ $(OCAMLC) $(DEVFLAGS) $(INCLUDES) -c $<
+
+ .mlcpp.ml:
+- @$(CPP) -x c -P $< $(FIX_BROKEN_CPP) -o $@
++ @$(CPP) -x c -P $< $(FIX_BROKEN_CPP) > $@
+
+ %.ml: %.mlp $(BITSTRING)/pa_bitstring.cmo
+ $(CAMLP4OF) build/bitstring.cma $(BITSTRING)/bitstring_persistent.cmo $(BITSTRING)/pa_bitstring.cmo -impl $< -o $@
--- /dev/null
+--- setup.ml 2011-03-22 17:00:48.000000000 +0100
++++ setup.ml 2011-12-22 21:41:25.000000000 +0100
+@@ -2662,10 +2662,14 @@
+ (ocamlc_config_map ())
+ 0
+ in
+- let nm_config =
++ let chop_version_suffix s =
++ try String.sub s 0 (String.index s '+')
++ with _ -> s
++ in
++ let nm_config, value_config =
+ match nm with
+- | "ocaml_version" -> "version"
+- | _ -> nm
++ | "ocaml_version" -> "version", chop_version_suffix
++ | _ -> nm, (fun x -> x)
+ in
+ var_redefine
+ nm
+@@ -2677,7 +2681,7 @@
+ let value =
+ SMap.find nm_config map
+ in
+- value
++ value_config value
+ with Not_found ->
+ failwithf2
+ (f_ "Cannot find field '%s' in '%s -config' output")
+@@ -3057,7 +3061,7 @@
+ begin
+ let acc =
+ try
+- Scanf.bscanf scbuf "%S %S@\n"
++ Scanf.bscanf scbuf "%S %S\n"
+ (fun e d ->
+ let t =
+ e, d
+--- setup.ml.orig 2012-03-17 11:50:20.000000000 +0100
++++ setup.ml 2012-07-31 17:45:43.000000000 +0200
+@@ -2284,7 +2284,13 @@
+ let cmdline =
+ String.concat " " (cmd :: args)
+ in
+- info (f_ "Running command '%s'") cmdline;
++ let printable_cmdline =
++ match List.rev args with
++ | _ :: (">" | "2>") :: rest ->
++ String.concat " " (cmd :: List.rev ("[file]" :: ">" :: rest))
++ | _ -> cmdline
++ in
++ info (f_ "Running command '%s'") printable_cmdline;
+ match f_exit_code, Sys.command cmdline with
+ | None, 0 -> ()
+ | None, i ->
--- /dev/null
+--- obrowser-1.1.1/Makefile.orig 2011-07-05 16:15:30.000000000 +0200
++++ obrowser-1.1.1/Makefile 2011-07-05 16:16:42.000000000 +0200
+@@ -16,9 +16,9 @@
+ EXAMPLES = $(patsubst examples/%,%, $(wildcard examples/*))
+ EXAMPLES_TARGETS = $(patsubst examples/%,%.example, $(wildcard examples/*))
+ OCAMLFIND = ocamlfind
+-.PHONY: tuto dist plugin lwt
++.PHONY: tuto dist plugin lwt AXO
+
+-all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt
++all: .check_version rt/caml/stdlib.cma vm.js tuto AXO $(EXAMPLES_TARGETS) examples.html lwt
+
+ .check_version:
+ @[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \
+--- obrowser-1.1.1.orig/Makefile 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/Makefile 2012-03-12 16:55:44.000000000 +0100
+@@ -21,10 +21,11 @@
+ all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt
+
+ .check_version:
+- @[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \
+- [ "$(shell ocamlc -vnum)" = "3.12.1" ] || \
+- ( echo "You need ocaml version 3.12.0 or 3.12.1"; \
+- exit 1 )
++ @case `ocaml -vnum` in \
++ 3.1[2-9].*);; \
++ 4.*);; \
++ *) echo "You need ocaml version 3.12.0 or later"; exit 1;; \
++ esac
+ touch $@
+
+ %.example:
+--- obrowser-1.1.1.orig/rt/caml/pervasives.mli 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.mli 2012-01-12 01:07:49.000000000 +0100
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (* *)
+-(* Objective Caml *)
++(* OCaml *)
+ (* *)
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+ (* *)
+@@ -52,24 +52,24 @@
+ Equality between cyclic data structures may not terminate. *)
+
+ external ( <> ) : 'a -> 'a -> bool = "%notequal"
+-(** Negation of {!Pervasives.(=)}. *)
++(** Negation of {!Pervasives.( = )}. *)
+
+ external ( < ) : 'a -> 'a -> bool = "%lessthan"
+-(** See {!Pervasives.(>=)}. *)
++(** See {!Pervasives.( >= )}. *)
+
+ external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+-(** See {!Pervasives.(>=)}. *)
++(** See {!Pervasives.( >= )}. *)
+
+ external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+-(** See {!Pervasives.(>=)}. *)
++(** See {!Pervasives.( >= )}. *)
+
+ external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+ (** Structural ordering functions. These functions coincide with
+ the usual orderings over integers, characters, strings
+ and floating-point numbers, and extend them to a
+ total ordering over all types.
+- The ordering is compatible with [(=)]. As in the case
+- of [(=)], mutable structures are compared by contents.
++ The ordering is compatible with [( = )]. As in the case
++ of [( = )], mutable structures are compared by contents.
+ Comparison between functional values raises [Invalid_argument].
+ Comparison between cyclic structures may not terminate. *)
+
+@@ -108,12 +108,12 @@
+ mutable fields and objects with mutable instance variables,
+ [e1 == e2] is true if and only if physical modification of [e1]
+ also affects [e2].
+- On non-mutable types, the behavior of [(==)] is
++ On non-mutable types, the behavior of [( == )] is
+ implementation-dependent; however, it is guaranteed that
+ [e1 == e2] implies [compare e1 e2 = 0]. *)
+
+ external ( != ) : 'a -> 'a -> bool = "%noteq"
+-(** Negation of {!Pervasives.(==)}. *)
++(** Negation of {!Pervasives.( == )}. *)
+
+
+ (** {6 Boolean operations} *)
+@@ -229,7 +229,7 @@
+
+ (** {6 Floating-point arithmetic}
+
+- Caml's floating-point numbers follow the
++ OCaml's floating-point numbers follow the
+ IEEE 754 standard, using double precision (64 bits) numbers.
+ Floating-point operations never raise an exception on overflow,
+ underflow, division by zero, etc. Instead, special IEEE numbers
+@@ -310,10 +310,18 @@
+ Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
+-(** [atan x y] returns the arc tangent of [y /. x]. The signs of [x]
++(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x]
+ and [y] are used to determine the quadrant of the result.
+ Result is in radians and is between [-pi] and [pi]. *)
+
++external hypot : float -> float -> float
++ = "caml_hypot_float" "caml_hypot" "float"
++(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
++ of the hypotenuse of a right-angled triangle with sides of length
++ [x] and [y], or, equivalently, the distance of the point [(x,y)]
++ to origin.
++ @since 3.13.0 *)
++
+ external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+ (** Hyperbolic cosine. Argument is in radians. *)
+
+@@ -337,6 +345,14 @@
+ external abs_float : float -> float = "%absfloat"
+ (** [abs_float f] returns the absolute value of [f]. *)
+
++external copysign : float -> float -> float
++ = "caml_copysign_float" "caml_copysign" "float"
++(** [copysign x y] returns a float whose absolute value is that of [x]
++ and whose sign is that of [y]. If [x] is [nan], returns [nan].
++ If [y] is [nan], returns either [x] or [-. x], but it is not
++ specified which.
++ @since 3.13.0 *)
++
+ external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+ (** [mod_float a b] returns the remainder of [a] with respect to
+ [b]. The returned value is [a -. n *. b], where [n]
+@@ -505,7 +521,7 @@
+ (** The standard output for the process. *)
+
+ val stderr : out_channel
+-(** The standard error ouput for the process. *)
++(** The standard error output for the process. *)
+
+
+ (** {7 Output functions on standard output} *)
+@@ -642,7 +658,7 @@
+ The given integer is taken modulo 2{^32}.
+ The only reliable way to read it back is through the
+ {!Pervasives.input_binary_int} function. The format is compatible across
+- all machines for a given version of Objective Caml. *)
++ all machines for a given version of OCaml. *)
+
+ val output_value : out_channel -> 'a -> unit
+ (** Write the representation of a structured value of any type
+@@ -855,12 +871,16 @@
+ (** Format strings have a general and highly polymorphic type
+ [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
+ The two simplified types, [format] and [format4] below are
+- included for backward compatibility with earlier releases of Objective
+- Caml.
++ included for backward compatibility with earlier releases of OCaml.
+ ['a] is the type of the parameters of the format,
+- ['c] is the result type for the "printf"-style function,
+- and ['b] is the type of the first argument given to
+- [%a] and [%t] printing functions. *)
++ ['b] is the type of the first argument given to
++ [%a] and [%t] printing functions,
++ ['c] is the type of the argument transmitted to the first argument of
++ "kprintf"-style functions,
++ ['d] is the result type for the "scanf"-style functions,
++ ['e] is the type of the receiver function for the "scanf"-style functions,
++ ['f] is the result type for the "printf"-style function.
++ *)
+ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+@@ -888,7 +908,7 @@
+ (** Terminate the process, returning the given status code
+ to the operating system: usually 0 to indicate no errors,
+ and a small positive integer to indicate failure.
+- All open output channels are flushed with flush_all.
++ All open output channels are flushed with [flush_all].
+ An implicit [exit 0] is performed each time a program
+ terminates normally. An implicit [exit 2] is performed if the program
+ terminates early because of an uncaught exception. *)
+--- obrowser-1.1.1.orig/rt/caml/pervasives.ml 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.ml 2012-01-12 17:04:04.000000000 +0100
+@@ -91,6 +91,8 @@
+ external asin : float -> float = "caml_asin_float" "asin" "float"
+ external atan : float -> float = "caml_atan_float" "atan" "float"
+ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
++external hypot : float -> float -> float
++ = "caml_hypot_float" "caml_hypot" "float"
+ external cos : float -> float = "caml_cos_float" "cos" "float"
+ external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+ external log : float -> float = "caml_log_float" "log" "float"
+@@ -104,6 +106,8 @@
+ external ceil : float -> float = "caml_ceil_float" "ceil" "float"
+ external floor : float -> float = "caml_floor_float" "floor" "float"
+ external abs_float : float -> float = "%absfloat"
++external copysign : float -> float -> float
++ = "caml_copysign_float" "caml_copysign" "float"
+ external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+ external frexp : float -> float * int = "caml_frexp_float"
+ external ldexp : float -> int -> float = "caml_ldexp_float"
+--- obrowser-1.1.1.orig/rt/caml/list.ml 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/list.ml 2012-01-12 17:30:31.000000000 +0100
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (* *)
+-(* Objective Caml *)
++(* OCaml *)
+ (* *)
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+ (* *)
+@@ -56,6 +56,12 @@
+ [] -> []
+ | a::l -> let r = f a in r :: map f l
+
++let rec mapi i f = function
++ [] -> []
++ | a::l -> let r = f i a in r :: mapi (i + 1) f l
++
++let mapi f l = mapi 0 f l
++
+ let rev_map f l =
+ let rec rmap_f accu = function
+ | [] -> accu
+@@ -68,6 +74,12 @@
+ [] -> ()
+ | a::l -> f a; iter f l
+
++let rec iteri i f = function
++ [] -> ()
++ | a::l -> f i a; iteri (i + 1) f l
++
++let iteri f l = iteri 0 f l
++
+ let rec fold_left f accu l =
+ match l with
+ [] -> accu
+--- obrowser-1.1.1.orig/rt/caml/list.mli 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/list.mli 2012-01-12 17:30:31.000000000 +0100
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (* *)
+-(* Objective Caml *)
++(* OCaml *)
+ (* *)
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+ (* *)
+@@ -75,11 +75,25 @@
+ [a1; ...; an]. It is equivalent to
+ [begin f a1; f a2; ...; f an; () end]. *)
+
++val iteri : (int -> 'a -> unit) -> 'a list -> unit
++(** Same as {!List.iter}, but the function is applied to the index of
++ the element as first argument (counting from 0), and the element
++ itself as second argument.
++ @since 3.13.0
++*)
++
+ val map : ('a -> 'b) -> 'a list -> 'b list
+ (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+ and builds the list [[f a1; ...; f an]]
+ with the results returned by [f]. Not tail-recursive. *)
+
++val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
++(** Same as {!List.map}, but the function is applied to the index of
++ the element as first argument (counting from 0), and the element
++ itself as second argument. Not tail-recursive.
++ @since 3.13.0
++*)
++
+ val rev_map : ('a -> 'b) -> 'a list -> 'b list
+ (** [List.rev_map f l] gives the same result as
+ {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
+--- obrowser-1.1.1-old/rt/caml/pervasives.mli 2013-06-20 13:50:19.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.mli 2013-06-20 13:50:59.000000000 +0200
+@@ -11,8 +11,6 @@
+ (* *)
+ (***********************************************************************)
+
+-(* $Id: pervasives.mli 10548 2010-06-09 10:26:19Z weis $ *)
+-
+ (** The initially opened module.
+
+ This module provides the basic operations over the built-in types
+@@ -122,7 +120,7 @@
+ (** The boolean negation. *)
+
+ external ( && ) : bool -> bool -> bool = "%sequand"
+-(** The boolean ``and''. Evaluation is sequential, left-to-right:
++(** The boolean 'and'. Evaluation is sequential, left-to-right:
+ in [e1 && e2], [e1] is evaluated first, and if it returns [false],
+ [e2] is not evaluated at all. *)
+
+@@ -130,7 +128,7 @@
+ (** @deprecated {!Pervasives.( && )} should be used instead. *)
+
+ external ( || ) : bool -> bool -> bool = "%sequor"
+-(** The boolean ``or''. Evaluation is sequential, left-to-right:
++(** The boolean 'or'. Evaluation is sequential, left-to-right:
+ in [e1 || e2], [e1] is evaluated first, and if it returns [true],
+ [e2] is not evaluated at all. *)
+
+@@ -138,6 +136,20 @@
+ (** @deprecated {!Pervasives.( || )} should be used instead.*)
+
+
++(** {6 Composition operators} *)
++
++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
++(** Reverse-application operator: [x |> f |> g] is exactly equivalent
++ to [g (f (x))].
++ @since 4.01
++*)
++
++external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
++(** Application operator: [g @@ f @@ x] is exactly equivalent to
++ [g (f (x))].
++ @since 4.01
++*)
++
+ (** {6 Integer arithmetic} *)
+
+ (** Integers are 31 bits wide (or 63 bits on 64-bit processors).
+@@ -234,7 +246,7 @@
+ Floating-point operations never raise an exception on overflow,
+ underflow, division by zero, etc. Instead, special IEEE numbers
+ are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
+- [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'')
++ [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
+ for [0.0 /. 0.0]. These special numbers then propagate through
+ floating-point computations as expected: for instance,
+ [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
+@@ -320,7 +332,7 @@
+ of the hypotenuse of a right-angled triangle with sides of length
+ [x] and [y], or, equivalently, the distance of the point [(x,y)]
+ to origin.
+- @since 3.13.0 *)
++ @since 4.00.0 *)
+
+ external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+ (** Hyperbolic cosine. Argument is in radians. *)
+@@ -351,7 +363,7 @@
+ and whose sign is that of [y]. If [x] is [nan], returns [nan].
+ If [y] is [nan], returns either [x] or [-. x], but it is not
+ specified which.
+- @since 3.13.0 *)
++ @since 4.00.0 *)
+
+ external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+ (** [mod_float a b] returns the remainder of [a] with respect to
+@@ -395,7 +407,7 @@
+ val nan : float
+ (** A special floating-point value denoting the result of an
+ undefined operation such as [0.0 /. 0.0]. Stands for
+- ``not a number''. Any floating-point operation with [nan] as
++ 'not a number'. Any floating-point operation with [nan] as
+ argument returns [nan] as result. As for floating-point comparisons,
+ [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
+ if one or both of their arguments is [nan]. *)
+@@ -461,7 +473,9 @@
+ (** {6 String conversion functions} *)
+
+ val string_of_bool : bool -> string
+-(** Return the string representation of a boolean. *)
++(** Return the string representation of a boolean. As the returned values
++ may be shared, the user should not modify them directly.
++*)
+
+ val bool_of_string : string -> bool
+ (** Convert the given string to a boolean.
+@@ -506,7 +520,9 @@
+ (** List concatenation. *)
+
+
+-(** {6 Input/output} *)
++(** {6 Input/output}
++ Note: all input/output functions can raise [Sys_error] when the system
++ calls they invoke fail. *)
+
+ type in_channel
+ (** The type of input channel. *)
+@@ -864,23 +880,73 @@
+
+ (** {6 Operations on format strings} *)
+
+-(** Format strings are used to read and print data using formatted input
+- functions in module {!Scanf} and formatted output in modules {!Printf} and
+- {!Format}. *)
++(** Format strings are character strings with special lexical conventions
++ that defines the functionality of formatted input/output functions. Format
++ strings are used to read data with formatted input functions from module
++ {!Scanf} and to print data with formatted output functions from modules
++ {!Printf} and {!Format}.
++
++ Format strings are made of three kinds of entities:
++ - {e conversions specifications}, introduced by the special character ['%']
++ followed by one or more characters specifying what kind of argument to
++ read or print,
++ - {e formatting indications}, introduced by the special character ['@']
++ followed by one or more characters specifying how to read or print the
++ argument,
++ - {e plain characters} that are regular characters with usual lexical
++ conventions. Plain characters specify string literals to be read in the
++ input or printed in the output.
++
++ There is an additional lexical rule to escape the special characters ['%']
++ and ['@'] in format strings: if a special character follows a ['%']
++ character, it is treated as a plain character. In other words, ["%%"] is
++ considered as a plain ['%'] and ["%@"] as a plain ['@'].
++
++ For more information about conversion specifications and formatting
++ indications available, read the documentation of modules {!Scanf},
++ {!Printf} and {!Format}.
++*)
+
+ (** Format strings have a general and highly polymorphic type
+ [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
+ The two simplified types, [format] and [format4] below are
+- included for backward compatibility with earlier releases of OCaml.
+- ['a] is the type of the parameters of the format,
+- ['b] is the type of the first argument given to
+- [%a] and [%t] printing functions,
+- ['c] is the type of the argument transmitted to the first argument of
+- "kprintf"-style functions,
+- ['d] is the result type for the "scanf"-style functions,
+- ['e] is the type of the receiver function for the "scanf"-style functions,
+- ['f] is the result type for the "printf"-style function.
+- *)
++ included for backward compatibility with earlier releases of
++ OCaml.
++
++ The meaning of format string type parameters is as follows:
++
++ - ['a] is the type of the parameters of the format for formatted output
++ functions ([printf]-style functions);
++ ['a] is the type of the values read by the format for formatted input
++ functions ([scanf]-style functions).
++
++ - ['b] is the type of input source for formatted input functions and the
++ type of output target for formatted output functions.
++ For [printf]-style functions from module [Printf], ['b] is typically
++ [out_channel];
++ for [printf]-style functions from module [Format], ['b] is typically
++ [Format.formatter];
++ for [scanf]-style functions from module [Scanf], ['b] is typically
++ [Scanf.Scanning.in_channel].
++
++ Type argument ['b] is also the type of the first argument given to
++ user's defined printing functions for [%a] and [%t] conversions,
++ and user's defined reading functions for [%r] conversion.
++
++ - ['c] is the type of the result of the [%a] and [%t] printing
++ functions, and also the type of the argument transmitted to the
++ first argument of [kprintf]-style functions or to the
++ [kscanf]-style functions.
++
++ - ['d] is the type of parameters for the [scanf]-style functions.
++
++ - ['e] is the type of the receiver function for the [scanf]-style functions.
++
++ - ['f] is the final result type of a formatted input/output function
++ invocation: for the [printf]-style functions, it is typically [unit];
++ for the [scanf]-style functions, it is typically the result type of the
++ receiver function.
++*)
+ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+@@ -892,14 +958,22 @@
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+ (** [format_of_string s] returns a format string read from the string
+- literal [s]. *)
++ literal [s].
++ Note: [format_of_string] can not convert a string argument that is not a
++ literal. If you need this functionality, use the more general
++ {!Scanf.format_from_string} function.
++*)
+
+ val ( ^^ ) :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
+ ('a, 'b, 'c, 'd, 'g, 'h) format6
+-(** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format
+- that accepts arguments from [f1], then arguments from [f2]. *)
++(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
++ format string that behaves as the concatenation of format strings [f1] and
++ [f2]: in case of formatted output, it accepts arguments from [f1], then
++ arguments from [f2]; in case of formatted input, it returns results from
++ [f1], then results from [f2].
++*)
+
+
+ (** {6 Program termination} *)
+@@ -918,13 +992,12 @@
+ termination time. The functions registered with [at_exit]
+ will be called when the program executes {!Pervasives.exit},
+ or terminates, either normally or because of an uncaught exception.
+- The functions are called in ``last in, first out'' order:
++ The functions are called in 'last in, first out' order:
+ the function most recently added with [at_exit] is called first. *)
+
+ (**/**)
+
+-
+-(** {6 For system use only, not for the casual user} *)
++(* The following is for system use only. Do not call directly. *)
+
+ val valid_float_lexem : string -> string
+
+--- obrowser-1.1.1-old/rt/caml/pervasives.ml 2013-06-20 13:50:19.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.ml 2013-06-20 13:51:53.000000000 +0200
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (* *)
+-(* Objective Caml *)
++(* OCaml *)
+ (* *)
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+ (* *)
+@@ -11,8 +11,6 @@
+ (* *)
+ (***********************************************************************)
+
+-(* $Id: pervasives.ml 9412 2009-11-09 11:42:39Z weis $ *)
+-
+ (* type 'a option = None | Some of 'a *)
+
+ (* Exceptions *)
+@@ -24,66 +22,70 @@
+
+ exception Exit
+
++(* Composition operators *)
++
++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
++external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
++
+ (* Comparisons *)
+
+-external (=) : 'a -> 'a -> bool = "%equal"
+-external (<>) : 'a -> 'a -> bool = "%notequal"
+-external (<) : 'a -> 'a -> bool = "%lessthan"
+-external (>) : 'a -> 'a -> bool = "%greaterthan"
+-external (<=) : 'a -> 'a -> bool = "%lessequal"
+-external (>=) : 'a -> 'a -> bool = "%greaterequal"
+-external compare: 'a -> 'a -> int = "%compare"
++external ( = ) : 'a -> 'a -> bool = "%equal"
++external ( <> ) : 'a -> 'a -> bool = "%notequal"
++external ( < ) : 'a -> 'a -> bool = "%lessthan"
++external ( > ) : 'a -> 'a -> bool = "%greaterthan"
++external ( <= ) : 'a -> 'a -> bool = "%lessequal"
++external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
++external compare : 'a -> 'a -> int = "%compare"
+
+ let min x y = if x <= y then x else y
+ let max x y = if x >= y then x else y
+
+-external (==) : 'a -> 'a -> bool = "%eq"
+-external (!=) : 'a -> 'a -> bool = "%noteq"
++external ( == ) : 'a -> 'a -> bool = "%eq"
++external ( != ) : 'a -> 'a -> bool = "%noteq"
+
+ (* Boolean operations *)
+
+ external not : bool -> bool = "%boolnot"
+-external (&) : bool -> bool -> bool = "%sequand"
+-external (&&) : bool -> bool -> bool = "%sequand"
+-external (or) : bool -> bool -> bool = "%sequor"
+-external (||) : bool -> bool -> bool = "%sequor"
++external ( & ) : bool -> bool -> bool = "%sequand"
++external ( && ) : bool -> bool -> bool = "%sequand"
++external ( or ) : bool -> bool -> bool = "%sequor"
++external ( || ) : bool -> bool -> bool = "%sequor"
+
+ (* Integer operations *)
+
+-external (~-) : int -> int = "%negint"
+-external (~+) : int -> int = "%identity"
++external ( ~- ) : int -> int = "%negint"
++external ( ~+ ) : int -> int = "%identity"
+ external succ : int -> int = "%succint"
+ external pred : int -> int = "%predint"
+-external (+) : int -> int -> int = "%addint"
+-external (-) : int -> int -> int = "%subint"
+-external ( * ) : int -> int -> int = "%mulint"
+-external (/) : int -> int -> int = "%divint"
+-external (mod) : int -> int -> int = "%modint"
++external ( + ) : int -> int -> int = "%addint"
++external ( - ) : int -> int -> int = "%subint"
++external ( * ) : int -> int -> int = "%mulint"
++external ( / ) : int -> int -> int = "%divint"
++external ( mod ) : int -> int -> int = "%modint"
+
+ let abs x = if x >= 0 then x else -x
+
+-external (land) : int -> int -> int = "%andint"
+-external (lor) : int -> int -> int = "%orint"
+-external (lxor) : int -> int -> int = "%xorint"
++external ( land ) : int -> int -> int = "%andint"
++external ( lor ) : int -> int -> int = "%orint"
++external ( lxor ) : int -> int -> int = "%xorint"
+
+ let lnot x = x lxor (-1)
+
+-external (lsl) : int -> int -> int = "%lslint"
+-external (lsr) : int -> int -> int = "%lsrint"
+-external (asr) : int -> int -> int = "%asrint"
++external ( lsl ) : int -> int -> int = "%lslint"
++external ( lsr ) : int -> int -> int = "%lsrint"
++external ( asr ) : int -> int -> int = "%asrint"
+
+-let min_int = 1 lsl (if 1 lsl 32 = 1 then 31 else 63) (* obrowser mod: no tag bit*)
++let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62)
+ let max_int = min_int - 1
+
+-
+ (* Floating-point operations *)
+
+-external (~-.) : float -> float = "%negfloat"
+-external (~+.) : float -> float = "%identity"
+-external (+.) : float -> float -> float = "%addfloat"
+-external (-.) : float -> float -> float = "%subfloat"
++external ( ~-. ) : float -> float = "%negfloat"
++external ( ~+. ) : float -> float = "%identity"
++external ( +. ) : float -> float -> float = "%addfloat"
++external ( -. ) : float -> float -> float = "%subfloat"
+ external ( *. ) : float -> float -> float = "%mulfloat"
+-external (/.) : float -> float -> float = "%divfloat"
++external ( /. ) : float -> float -> float = "%divfloat"
+ external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
+ external exp : float -> float = "caml_exp_float" "exp" "float"
+ external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float"
+@@ -136,16 +138,16 @@
+ | FP_zero
+ | FP_infinite
+ | FP_nan
+-external classify_float: float -> fpclass = "caml_classify_float"
++external classify_float : float -> fpclass = "caml_classify_float"
+
+ (* String operations -- more in module String *)
+
+ external string_length : string -> int = "%string_length"
+-external string_create: int -> string = "caml_create_string"
++external string_create : int -> string = "caml_create_string"
+ external string_blit : string -> int -> string -> int -> int -> unit
+ = "caml_blit_string" "noalloc"
+
+-let (^) s1 s2 =
++let ( ^ ) s1 s2 =
+ let l1 = string_length s1 and l2 = string_length s2 in
+ let s = string_create (l1 + l2) in
+ string_blit s1 0 s 0 l1;
+@@ -170,8 +172,8 @@
+
+ (* String conversion functions *)
+
+-external format_int: string -> int -> string = "caml_format_int"
+-external format_float: string -> float -> string = "caml_format_float"
++external format_int : string -> int -> string = "caml_format_int"
++external format_float : string -> float -> string = "caml_format_float"
+
+ let string_of_bool b =
+ if b then "true" else "false"
+@@ -187,7 +189,6 @@
+
+ module String = struct
+ external get : string -> int -> char = "%string_safe_get"
+- external set : string -> int -> char -> unit = "%string_safe_set"
+ end
+
+ let valid_float_lexem s =
+@@ -195,7 +196,7 @@
+ let rec loop i =
+ if i >= l then s ^ "." else
+ match s.[i] with
+- | '0' .. '9' | '-' -> loop (i+1)
++ | '0' .. '9' | '-' -> loop (i + 1)
+ | _ -> s
+ in
+ loop 0
+@@ -207,7 +208,7 @@
+
+ (* List operations -- more in module List *)
+
+-let rec (@) l1 l2 =
++let rec ( @ ) l1 l2 =
+ match l1 with
+ [] -> l2
+ | hd :: tl -> hd :: (tl @ l2)
+@@ -217,12 +218,13 @@
+ type in_channel
+ type out_channel
+
+-let open_descriptor_out _ = failwith "not implemented in obrowser"
+-let open_descriptor_in _ = failwith "not implemented in obrowser"
+-
+-let stdin = Obj.magic 0
+-let stdout = Obj.magic 0
+-let stderr = Obj.magic 0
++external open_descriptor_out : int -> out_channel
++ = "caml_ml_open_descriptor_out"
++external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
++
++let stdin = open_descriptor_in 0
++let stdout = open_descriptor_out 1
++let stderr = open_descriptor_out 2
+
+ (* General output functions *)
+
+@@ -231,103 +233,184 @@
+ | Open_creat | Open_trunc | Open_excl
+ | Open_binary | Open_text | Open_nonblock
+
+-let open_desc _ _ _ = failwith "not implemented in obrowser"
+-let open_out_gen mode perm name = failwith "not implemented in obrowser"
+-let open_out name = failwith "not implemented in obrowser"
+-let open_out_bin name = failwith "not implemented in obrowser"
+-let flush _ = failwith "not implemented in obrowser"
+-let out_channels_list _ = failwith "not implemented in obrowser"
+-let flush_all () = failwith "not implemented in obrowser"
+-let unsafe_output _ _ _ _ = failwith "not implemented in obrowser"
+-let output_char _ _ = failwith "not implemented in obrowser"
+-let output_string oc s = failwith "not implemented in obrowser"
+-let output oc s ofs len = failwith "not implemented in obrowser"
+-let output_byte _ _ = failwith "not implemented in obrowser"
+-let output_binary_int _ _ = failwith "not implemented in obrowser"
+-let marshal_to_channel _ _ _ = failwith "not implemented in obrowser"
+-let output_value _ _ = failwith "not implemented in obrowser"
+-let seek_out _ _ = failwith "not implemented in obrowser"
+-let pos_out _ = failwith "not implemented in obrowser"
+-let out_channel_length _ = failwith "not implemented in obrowser"
+-let close_out_channel _ = failwith "not implemented in obrowser"
+-let close_out _ = failwith "not implemented in obrowser"
+-let close_out_noerr _ = failwith "not implemented in obrowser"
+-let set_binary_mode_out _ _ = failwith "not implemented in obrowser"
++external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
++
++let open_out_gen mode perm name =
++ open_descriptor_out(open_desc name mode perm)
++
++let open_out name =
++ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
++
++let open_out_bin name =
++ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
++
++external flush : out_channel -> unit = "caml_ml_flush"
++
++external out_channels_list : unit -> out_channel list
++ = "caml_ml_out_channels_list"
++
++let flush_all () =
++ let rec iter = function
++ [] -> ()
++ | a :: l -> (try flush a with _ -> ()); iter l
++ in iter (out_channels_list ())
++
++external unsafe_output : out_channel -> string -> int -> int -> unit
++ = "caml_ml_output"
++
++external output_char : out_channel -> char -> unit = "caml_ml_output_char"
++
++let output_string oc s =
++ unsafe_output oc s 0 (string_length s)
++
++let output oc s ofs len =
++ if ofs < 0 || len < 0 || ofs > string_length s - len
++ then invalid_arg "output"
++ else unsafe_output oc s ofs len
++
++external output_byte : out_channel -> int -> unit = "caml_ml_output_char"
++external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int"
++
++external marshal_to_channel : out_channel -> 'a -> unit list -> unit
++ = "caml_output_value"
++let output_value chan v = marshal_to_channel chan v []
++
++external seek_out : out_channel -> int -> unit = "caml_ml_seek_out"
++external pos_out : out_channel -> int = "caml_ml_pos_out"
++external out_channel_length : out_channel -> int = "caml_ml_channel_size"
++external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
++let close_out oc = flush oc; close_out_channel oc
++let close_out_noerr oc =
++ (try flush oc with _ -> ());
++ (try close_out_channel oc with _ -> ())
++external set_binary_mode_out : out_channel -> bool -> unit
++ = "caml_ml_set_binary_mode"
+
+ (* General input functions *)
+
+-let open_in_gen _ _ _ = failwith "not implemented in obrowser"
+-let open_in _ = failwith "not implemented in obrowser"
+-let open_in_bin _ = failwith "not implemented in obrowser"
+-let input_char _ = failwith "not implemented in obrowser"
+-let unsafe_input _ _ _ _ = failwith "not implemented in obrowser"
+-let input _ _ _ _ = failwith "not implemented in obrowser"
+-let rec unsafe_really_input _ _ _ _ = failwith "not implemented in obrowser"
+-let really_input _ _ _ _ = failwith "not implemented in obrowser"
+-let input_scan_line _ = failwith "not implemented in obrowser"
+-let input_line _ = failwith "not implemented in obrowser"
+-
+-let input_byte _ = failwith "not implemented in obrowser"
+-let input_binary_int _ = failwith "not implemented in obrowser"
+-let input_value _ = failwith "not implemented in obrowser"
+-let seek_in _ _ = failwith "not implemented in obrowser"
+-let pos_in _ = failwith "not implemented in obrowser"
+-let in_channel_length _ = failwith "not implemented in obrowser"
+-let close_in _ = failwith "not implemented in obrowser"
+-let close_in_noerr _ = failwith "not implemented in obrowser"
+-let set_binary_mode_in _ _ = failwith "not implemented in obrowser"
++let open_in_gen mode perm name =
++ open_descriptor_in(open_desc name mode perm)
+
+-(* Output functions on standard output *)
++let open_in name =
++ open_in_gen [Open_rdonly; Open_text] 0 name
++
++let open_in_bin name =
++ open_in_gen [Open_rdonly; Open_binary] 0 name
++
++external input_char : in_channel -> char = "caml_ml_input_char"
++
++external unsafe_input : in_channel -> string -> int -> int -> int
++ = "caml_ml_input"
++
++let input ic s ofs len =
++ if ofs < 0 || len < 0 || ofs > string_length s - len
++ then invalid_arg "input"
++ else unsafe_input ic s ofs len
++
++let rec unsafe_really_input ic s ofs len =
++ if len <= 0 then () else begin
++ let r = unsafe_input ic s ofs len in
++ if r = 0
++ then raise End_of_file
++ else unsafe_really_input ic s (ofs + r) (len - r)
++ end
+
+-external basic_io_write : string -> unit = "caml_basic_io_write"
++let really_input ic s ofs len =
++ if ofs < 0 || len < 0 || ofs > string_length s - len
++ then invalid_arg "really_input"
++ else unsafe_really_input ic s ofs len
++
++external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
++
++let input_line chan =
++ let rec build_result buf pos = function
++ [] -> buf
++ | hd :: tl ->
++ let len = string_length hd in
++ string_blit hd 0 buf (pos - len) len;
++ build_result buf (pos - len) tl in
++ let rec scan accu len =
++ let n = input_scan_line chan in
++ if n = 0 then begin (* n = 0: we are at EOF *)
++ match accu with
++ [] -> raise End_of_file
++ | _ -> build_result (string_create len) len accu
++ end else if n > 0 then begin (* n > 0: newline found in buffer *)
++ let res = string_create (n - 1) in
++ ignore (unsafe_input chan res 0 (n - 1));
++ ignore (input_char chan); (* skip the newline *)
++ match accu with
++ [] -> res
++ | _ -> let len = len + n - 1 in
++ build_result (string_create len) len (res :: accu)
++ end else begin (* n < 0: newline not found *)
++ let beg = string_create (-n) in
++ ignore(unsafe_input chan beg 0 (-n));
++ scan (beg :: accu) (len - n)
++ end
++ in scan [] 0
++
++external input_byte : in_channel -> int = "caml_ml_input_char"
++external input_binary_int : in_channel -> int = "caml_ml_input_int"
++external input_value : in_channel -> 'a = "caml_input_value"
++external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
++external pos_in : in_channel -> int = "caml_ml_pos_in"
++external in_channel_length : in_channel -> int = "caml_ml_channel_size"
++external close_in : in_channel -> unit = "caml_ml_close_channel"
++let close_in_noerr ic = (try close_in ic with _ -> ());;
++external set_binary_mode_in : in_channel -> bool -> unit
++ = "caml_ml_set_binary_mode"
+
+-let print_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s)
+-let print_string s = basic_io_write s
+-let print_int i = basic_io_write (string_of_int i)
+-let print_float f = basic_io_write (string_of_float f)
++(* Output functions on standard output *)
++
++let print_char c = output_char stdout c
++let print_string s = output_string stdout s
++let print_int i = output_string stdout (string_of_int i)
++let print_float f = output_string stdout (string_of_float f)
+ let print_endline s =
+- print_string s; print_char '\n'
+-let print_newline () = print_char '\n'
++ output_string stdout s; output_char stdout '\n'; flush stdout
++let print_newline () = output_char stdout '\n'; flush stdout
+
+ (* Output functions on standard error *)
+
+-let prerr_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s)
+-let prerr_string s = basic_io_write s
+-let prerr_int i = basic_io_write (string_of_int i)
+-let prerr_float f = basic_io_write (string_of_float f)
++let prerr_char c = output_char stderr c
++let prerr_string s = output_string stderr s
++let prerr_int i = output_string stderr (string_of_int i)
++let prerr_float f = output_string stderr (string_of_float f)
+ let prerr_endline s =
+- prerr_string s; prerr_char '\n'
+-let prerr_newline () = prerr_char '\n'
++ output_string stderr s; output_char stderr '\n'; flush stderr
++let prerr_newline () = output_char stderr '\n'; flush stderr
+
+ (* Input functions on standard input *)
+
+-let read_line () = failwith "not implemented in obrowser"
+-let read_int () = failwith "not implemented in obrowser"
+-let read_float () = failwith "not implemented in obrowser"
++let read_line () = flush stdout; input_line stdin
++let read_int () = int_of_string(read_line())
++let read_float () = float_of_string(read_line())
+
+ (* Operations on large files *)
+
+ module LargeFile =
+ struct
+- let seek_out _ _ = failwith "not implemented in obrowser"
+- let pos_out _ = failwith "not implemented in obrowser"
+- let out_channel_length _ = failwith "not implemented in obrowser"
+- let seek_in _ _ = failwith "not implemented in obrowser"
+- let pos_in _ = failwith "not implemented in obrowser"
+- let in_channel_length _ = failwith "not implemented in obrowser"
++ external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
++ external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
++ external out_channel_length : out_channel -> int64
++ = "caml_ml_channel_size_64"
++ external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
++ external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
++ external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
+ end
+
+ (* References *)
+
+-type 'a ref = { mutable contents: 'a }
+-external ref: 'a -> 'a ref = "%makemutable"
+-external (!): 'a ref -> 'a = "%field0"
+-external (:=): 'a ref -> 'a -> unit = "%setfield0"
+-external incr: int ref -> unit = "%incr"
+-external decr: int ref -> unit = "%decr"
++type 'a ref = { mutable contents : 'a }
++external ref : 'a -> 'a ref = "%makemutable"
++external ( ! ) : 'a ref -> 'a = "%field0"
++external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
++external incr : int ref -> unit = "%incr"
++external decr : int ref -> unit = "%decr"
+
+ (* Formats *)
+-type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
++type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+@@ -345,7 +428,8 @@
+ ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
+ ('a, 'b, 'c, 'd, 'g, 'h) format6) =
+ fun fmt1 fmt2 ->
+- string_to_format (format_to_string fmt1 ^ format_to_string fmt2);;
++ string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2)
++;;
+
+ let string_of_format fmt =
+ let s = format_to_string fmt in
+@@ -358,7 +442,7 @@
+
+ external sys_exit : int -> 'a = "caml_sys_exit"
+
+-let exit_function = ref (fun () -> ())
++let exit_function = ref flush_all
+
+ let at_exit f =
+ let g = !exit_function in
+--- obrowser-1.1.1.orig/rt/caml/printexc.ml 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/printexc.ml 2013-08-13 15:54:35.000000000 +0200
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (* *)
+-(* Objective Caml *)
++(* OCaml *)
+ (* *)
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+ (* *)
+@@ -11,8 +11,6 @@
+ (* *)
+ (***********************************************************************)
+
+-(* $Id: printexc.ml 10272 2010-04-19 12:25:46Z frisch $ *)
+-
+ open Printf;;
+
+ let printers = ref []
+@@ -56,9 +54,12 @@
+ sprintf locfmt file line char (char+5) "Pattern matching failed"
+ | Assert_failure(file, line, char) ->
+ sprintf locfmt file line char (char+6) "Assertion failed"
++ | Undefined_recursive_module(file, line, char) ->
++ sprintf locfmt file line char (char+6) "Undefined recursive module"
+ | _ ->
+ let x = Obj.repr x in
+- let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
++ let constructor =
++ (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
+ constructor ^ (fields x) in
+ conv !printers
+
+@@ -78,6 +79,11 @@
+ eprintf "Uncaught exception: %s\n" (to_string x);
+ exit 2
+
++type raw_backtrace
++
++external get_raw_backtrace:
++ unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
++
+ type loc_info =
+ | Known_location of bool (* is_raise *)
+ * string (* filename *)
+@@ -86,8 +92,13 @@
+ * int (* end char *)
+ | Unknown_location of bool (*is_raise*)
+
+-external get_exception_backtrace:
+- unit -> loc_info array option = "caml_get_exception_backtrace"
++(* to avoid warning *)
++let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
++
++type backtrace = loc_info array
++
++external convert_raw_backtrace:
++ raw_backtrace -> backtrace option = "caml_convert_raw_backtrace"
+
+ let format_loc_info pos li =
+ let is_raise =
+@@ -108,8 +119,8 @@
+ sprintf "%s unknown location"
+ info
+
+-let print_backtrace outchan =
+- match get_exception_backtrace() with
++let print_exception_backtrace outchan backtrace =
++ match backtrace with
+ | None ->
+ fprintf outchan
+ "(Program not linked with -g, cannot print stack backtrace)\n"
+@@ -119,8 +130,15 @@
+ fprintf outchan "%s\n" (format_loc_info i a.(i))
+ done
+
+-let get_backtrace () =
+- match get_exception_backtrace() with
++let print_raw_backtrace outchan raw_backtrace =
++ print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
++
++(* confusingly named: prints the global current backtrace *)
++let print_backtrace outchan =
++ print_raw_backtrace outchan (get_raw_backtrace ())
++
++let backtrace_to_string backtrace =
++ match backtrace with
+ | None ->
+ "(Program not linked with -g, cannot print stack backtrace)\n"
+ | Some a ->
+@@ -131,8 +149,22 @@
+ done;
+ Buffer.contents b
+
++let raw_backtrace_to_string raw_backtrace =
++ backtrace_to_string (convert_raw_backtrace raw_backtrace)
++
++(* confusingly named:
++ returns the *string* corresponding to the global current backtrace *)
++let get_backtrace () =
++ (* we could use the caml_get_exception_backtrace primitive here, but
++ we hope to deprecate it so it's better to just compose the
++ raw stuff *)
++ backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
++
+ external record_backtrace: bool -> unit = "caml_record_backtrace"
+ external backtrace_status: unit -> bool = "caml_backtrace_status"
+
+ let register_printer fn =
+ printers := fn :: !printers
++
++
++external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
+--- obrowser-1.1.1.orig/rt/caml/printexc.mli 2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/printexc.mli 2013-08-13 15:54:40.000000000 +0200
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (* *)
+-(* Objective Caml *)
++(* OCaml *)
+ (* *)
+ (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+ (* *)
+@@ -11,9 +11,7 @@
+ (* *)
+ (***********************************************************************)
+
+-(* $Id: printexc.mli 10457 2010-05-21 18:30:12Z doligez $ *)
+-
+-(** Facilities for printing exceptions. *)
++(** Facilities for printing exceptions and inspecting current call stack. *)
+
+ val to_string: exn -> string
+ (** [Printexc.to_string e] returns a string representation of
+@@ -77,5 +75,40 @@
+ in the reverse order of their registrations, until a printer returns
+ a [Some s] value (if no such printer exists, the runtime will use a
+ generic printer).
++
++ When using this mechanism, one should be aware that an exception backtrace
++ is attached to the thread that saw it raised, rather than to the exception
++ itself. Practically, it means that the code related to [fn] should not use
++ the backtrace if it has itself raised an exception before.
+ @since 3.11.2
+ *)
++
++(** {6 Raw backtraces} *)
++
++type raw_backtrace
++
++(** The abstract type [backtrace] stores exception backtraces in
++ a low-level format, instead of directly exposing them as string as
++ the [get_backtrace()] function does.
++
++ This allows to pay the performance overhead of representation
++ conversion and formatting only at printing time, which is useful
++ if you want to record more backtrace than you actually print.
++*)
++
++val get_raw_backtrace: unit -> raw_backtrace
++val print_raw_backtrace: out_channel -> raw_backtrace -> unit
++val raw_backtrace_to_string: raw_backtrace -> string
++
++
++(** {6 Current call stack} *)
++
++val get_callstack: int -> raw_backtrace
++
++(** [Printexc.get_callstack n] returns a description of the top of the
++ call stack on the current program point (for the current thread),
++ with at most [n] entries. (Note: this function is not related to
++ exceptions at all, despite being part of the [Printexc] module.)
++
++ @since 4.01.0
++*)
--- /dev/null
+--- ocaml-bitstring-2.0.3/Makefile.in.orig 2013-04-04 17:42:45.000000000 +0200
++++ ocaml-bitstring-2.0.3/Makefile.in 2013-04-04 17:43:06.000000000 +0200
+@@ -123,7 +123,7 @@
+
+ byteswap.h: byteswap.in.h
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+- cat $(srcdir)/byteswap.in.h; \
++ cat byteswap.in.h; \
+ } > $@-t
+ mv -f $@-t $@
+
--- /dev/null
+--- ocaml-mysql-1.0.4.orig/mysql_stubs.c 2006-02-24 00:12:36.000000000 +0100
++++ ocaml-mysql-1.0.4/mysql_stubs.c 2012-08-09 20:51:24.000000000 +0200
+@@ -19,9 +19,9 @@
+
+ /* MySQL API */
+
+-#include <mysql/mysql.h>
+-#include <mysql/mysqld_error.h>
+-#include <mysql/errmsg.h>
++#include <mysql.h>
++#include <mysqld_error.h>
++#include <errmsg.h>
+ /* type 'a option = None | Some of 'a */
+
+ #define NONE Val_int(0)
--- /dev/null
+--- ocamlnet-3.5.1.orig/src/netsys/netsys_posix.ml 2011-10-12 14:09:05.000000000 +0200
++++ ocamlnet-3.5.1/src/netsys/netsys_posix.ml 2012-01-12 19:33:39.000000000 +0100
+@@ -412,9 +412,11 @@
+ type at_flag = AT_EACCESS | AT_SYMLINK_NOFOLLOW | AT_REMOVEDIR
+
+ (* The stubs assume these type definitions: *)
++(* In fact, they don't: they assume OCaml's stdlib definition
+ type open_flag1 = Unix.open_flag =
+ O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
+ | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC
++*)
+
+ type access_permission1 = Unix.access_permission =
+ R_OK | W_OK | X_OK | F_OK
+--- ocamlnet-3.5.1.orig/src/netstring/Makefile.def 2012-02-29 19:02:52.000000000 +0100
++++ ocamlnet-3.5.1/src/netstring/Makefile.def 2012-05-25 16:59:56.000000000 +0200
+@@ -13,7 +13,7 @@
+ PKGNAME = netstring
+
+ REQUIRES = $(REGEXP_PROVIDER) bigarray
+-INCLUDES += $(INC_NETSYS)
++INCLUDES += $(INC_NETSYS) -I +compiler-libs
+
+ ISO_MAPPINGS = mappings/iso*.unimap
+ JP_MAPPINGS = mappings/jis*.*map
+--- ocamlnet-3.5.1.orig/src/pop/netpop.ml 2012-02-29 19:02:53.000000000 +0100
++++ ocamlnet-3.5.1/src/pop/netpop.ml 2013-06-20 14:06:11.000000000 +0200
+@@ -231,6 +231,7 @@
+ status_response ic parse_line (Hashtbl.create 1)
+ with _ -> raise Protocol_error
+
++(*
+ method stat () =
+ self#check_state `Transaction;
+ send_command oc "STAT";
+@@ -242,4 +243,5 @@
+ (count, size, ext)
+ )
+ with _ -> raise Protocol_error;
++*)
+ end
--- /dev/null
+diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.lwt ocsigen-bundle-2.2.2/pkg/Makefile.lwt
+--- ocsigen-bundle-2.2.2.orig/pkg/Makefile.lwt 2011-12-20 16:13:24.000000000 +0100
++++ ocsigen-bundle-2.2.2/pkg/Makefile.lwt 2011-12-29 00:34:27.000000000 +0100
+@@ -70,7 +70,7 @@
+
+ ${METAS}/META.lwt: ${LWT_DIR}/src/core/META
+ echo "directory = \"${srcdir}/${LWT_DIR}/_build/src/core\"" > $@
+- sed -e 's%^package "\([^\"]*\)" (%package "\1" (\n directory = "../\1"%g' \
++ sed -e 's%^package "\([^\"]*\)" (%package "\1" ( directory = "../\1"%g' \
+ -e 's%../syntax%../../syntax%' \
+ $< >> $@
+
+diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.ocsimore ocsigen-bundle-2.2.2/pkg/Makefile.ocsimore
+--- ocsigen-bundle-2.2.2.orig/pkg/Makefile.ocsimore 2011-12-20 16:13:24.000000000 +0100
++++ ocsigen-bundle-2.2.2/pkg/Makefile.ocsimore 2011-12-29 00:34:51.000000000 +0100
+@@ -37,8 +37,8 @@
+
+ ${METAS}/META.ocsimore: ${OCSIMORE_DIR}/src/core/META
+ echo "directory = \"${srcdir}/${OCSIMORE_DIR}/_build/src/core\"" > $@
+- sed -e 's%^package "\([^\"]*\(user\|wiki\|site\|forum\)\)" (%package "\1" (\n directory = "../\2"%g' \
+- -e 's%^package "site_client" (%package "site_client" (\n directory = "../site/client"%g' \
++ sed -e 's%^package "\([^\"]*\(user\|wiki\|site\|forum\)\)" (%package "\1" ( directory = "../\2"%g' \
++ -e 's%^package "site_client" (%package "site_client" ( directory = "../site/client"%g' \
+ $< >> $@
+
+
+diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.tyxml ocsigen-bundle-2.2.2/pkg/Makefile.tyxml
+--- ocsigen-bundle-2.2.2.orig/pkg/Makefile.js_of_ocaml 2011-12-20 16:13:24.000000000 +0100
++++ ocsigen-bundle-2.2.2/pkg/Makefile.js_of_ocaml 2011-12-29 01:47:00.000000000 +0100
+@@ -47,5 +47,5 @@
+
+ ${METAS}/META.js_of_ocaml: ${JS_OF_OCAML_DIR}/lib/META
+ echo "directory = \"${srcdir}/${JS_OF_OCAML_DIR}/lib\"" > $@
+- sed -e 's%package "syntax" (%package "syntax" (\n directory = "syntax"%g' \
++ sed -e 's%package "syntax" (%package "syntax" ( directory = "syntax"%g' \
+ $< >> $@
+--- ocsigen-bundle-2.2.2/configure.orig 2012-05-25 18:33:10.000000000 +0200
++++ ocsigen-bundle-2.2.2/configure 2012-05-25 18:33:24.000000000 +0200
+@@ -11051,7 +11051,7 @@
+
+
+
+-build_projects="deriving-ocsigen lwt js_of_ocaml tyxml ocsigenserver eliom"
++build_projects="deriving-ocsigen js_of_ocaml tyxml ocsigenserver"
+ if test $enable_ocsimore = yes ; then :
+ build_projects+=" ocsimore"
+ fi
--- /dev/null
+--- omake-0.9.8.6.orig/lib/build/OCaml.om 2008-03-05 02:07:25.000000000 +0100
++++ omake-0.9.8.6/lib/build/OCaml.om 2011-05-02 22:53:23.000000000 +0200
+@@ -176,7 +176,7 @@
+ #
+ declare OCAMLDEPFLAGS
+ public.OCAMLPPFLAGS =
+-public.OCAMLFLAGS = -warn-error A
++public.OCAMLFLAGS = -warn-error a
+ public.OCAMLCFLAGS = -g
+ public.OCAMLOPTFLAGS =
+ public.OCAMLCPPFLAGS =
--- /dev/null
+diff -N -r -u sks-1.1.3.orig/Makefile.local sks-1.1.3/Makefile.local
+--- sks-1.1.3.orig/Makefile.local 1970-01-01 01:00:00.000000000 +0100
++++ sks-1.1.3/Makefile.local 2010-05-17 14:49:16.000000000 +0200
+@@ -0,0 +1,5 @@
++LIBDB=-ldb
++MANDIR=${PREFIX}/share/man
++export PREFIX
++export LIBDB
++export MANDIR
+--- sks-1.1.3.orig/Makefile 2012-04-11 04:03:25.000000000 +0200
++++ sks-1.1.3/Makefile 2013-05-30 14:40:03.000000000 +0200
+@@ -47,7 +47,7 @@
+
+ CAMLP4=-pp $(CAMLP4O)
+ CAMLINCLUDE= -I lib -I bdb
+-COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error A
++COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error a
+ OCAMLDEP=ocamldep $(CAMLP4)
+ CAMLLIBS=unix.cma str.cma bdb.cma nums.cma bigarray.cma cryptokit.cma
+ OCAMLFLAGS=$(COMMONCAMLFLAGS) -g $(CAMLLIBS)
--- /dev/null
+--- vsyml-2010-04-06.orig/makefile 2010-04-06 19:28:25.000000000 +0200
++++ vsyml-2010-04-06/makefile 2010-08-23 15:16:22.000000000 +0200
+@@ -525,13 +525,13 @@
+
+ # dependencies for the symbolic simulator main file on cmo cma cmx and cmxa
+ $(VSYML_CMO_LST): $(VSYML_MAIN)
+- echo -n "VSYML_CMO=" > $@
+- for i in `grep -o -e '[a-zA-Z0-9_]*\.cmo' $<` ; do echo -n $$i " " >> $@ ; done
++ echo "VSYML_CMO=" | tr -d '\012' > $@
++ for i in `grep -o -e '[a-zA-Z0-9_]*\.cmo' $<` ; do echo $$i " " | tr -d '\012' >> $@ ; done
+ echo $(patsubst $(SRC_PATH)$(PATH_SEPARATOR)%.ml,%.cmo,$<) >> $@
+
+ $(VSYML_CMA_LST): $(VSYML_MAIN)
+- echo -n "VSYML_CMA=" > $@
+- for i in `grep -o -e '[a-zA-Z0-9_]*\.cma' $<` ; do echo -n $$i " " >> $@ ; done
++ echo "VSYML_CMA=" | tr -d '\012' > $@
++ for i in `grep -o -e '[a-zA-Z0-9_]*\.cma' $<` ; do echo $$i " " | tr -d '\012' >> $@ ; done
+
+ $(VSYML_BYTE_CMO_LST): $(VSYML_CMO_LST)
+ sed -e 's@\([a-zA-Z0-9_]*\)\.cmo@$(BYTE_PATH)$(PATH_SEPARATOR)\1.cmo@g' -e 's/VSYML_CMO/VSYML_BYTE_CMO/' $< > $@
--- /dev/null
+--- xml-light/Makefile 2003-10-12 11:16:12.000000000 +0200
++++ xml-light-2.2/Makefile 2010-01-23 20:57:57.000000000 +0100
+@@ -2,7 +2,7 @@
+ # http://tech.motion-twin.com\r
+ .SUFFIXES : .ml .mli .cmo .cmx .cmi .mll .mly\r
+ \r
+-INSTALLDIR=`ocamlc -where`\r
++INSTALLDIR=`ocamlc -where`/xml-light\r
+ CFLAGS=\r
+ LFLAGS= -a\r
+ LIBS=\r
+@@ -12,6 +12,7 @@
+ opt: xml-light.cmxa test_opt.exe\r
+ \r
+ install: all opt\r
++ mkdir -p "${INSTALLDIR}"\r
+ cp xml-light.cmxa xml-light.a xml-light.cma xml.mli xmlParser.mli dtd.mli xml.cmi xmlParser.cmi dtd.cmi xml.cmx dtd.cmx xmlParser.cmx $(INSTALLDIR)\r
+ \r
+ doc:\r
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
default:
(* *)
(***********************************************************************)
-(* $Id: alloc.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Random allocation test *)
(*
+++ /dev/null
-
-minor_words: 6410964
-promoted_words: 6332175
-major_words: 6393661
-minor_collections: 196
-major_collections: 14
-heap_words: 3936256
-heap_chunks: 31
-top_heap_words: 3936256
-live_words: 2034808
-live_blocks: 31786
-free_words: 1901339
-free_blocks: 16531
-largest_free: 1357
-fragments: 109
-compactions: 0
-
-minor_words: 12805330
-promoted_words: 12664909
-major_words: 12739763
-minor_collections: 391
-major_collections: 21
-heap_words: 4571136
-heap_chunks: 36
-top_heap_words: 4571136
-live_words: 2126718
-live_blocks: 33282
-free_words: 2444325
-free_blocks: 19124
-largest_free: 1824
-fragments: 93
-compactions: 0
-
-minor_words: 19215544
-promoted_words: 18998176
-major_words: 19100845
-minor_collections: 586
-major_collections: 28
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2135891
-live_blocks: 33344
-free_words: 2562126
-free_blocks: 19238
-largest_free: 1405
-fragments: 95
-compactions: 0
-
-minor_words: 25638028
-promoted_words: 25361252
-major_words: 25472205
-minor_collections: 782
-major_collections: 35
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2137378
-live_blocks: 33350
-free_words: 2560637
-free_blocks: 19112
-largest_free: 1634
-fragments: 97
-compactions: 0
-
-minor_words: 32062298
-promoted_words: 31721945
-major_words: 31842628
-minor_collections: 978
-major_collections: 41
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2145462
-live_blocks: 33351
-free_words: 2552521
-free_blocks: 19013
-largest_free: 1999
-fragments: 129
-compactions: 0
-
-minor_words: 38449694
-promoted_words: 38049841
-major_words: 38176354
-minor_collections: 1173
-major_collections: 48
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2125014
-live_blocks: 33351
-free_words: 2572992
-free_blocks: 19080
-largest_free: 1525
-fragments: 106
-compactions: 0
-
-minor_words: 44846324
-promoted_words: 44379560
-major_words: 44521194
-minor_collections: 1368
-major_collections: 55
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2136556
-live_blocks: 33351
-free_words: 2561444
-free_blocks: 19191
-largest_free: 1760
-fragments: 112
-compactions: 0
-
-minor_words: 51240537
-promoted_words: 50707711
-major_words: 50862160
-minor_collections: 1563
-major_collections: 61
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2136623
-live_blocks: 33351
-free_words: 2561383
-free_blocks: 18967
-largest_free: 1526
-fragments: 106
-compactions: 0
-
-minor_words: 57628061
-promoted_words: 57038039
-major_words: 57197286
-minor_collections: 1758
-major_collections: 68
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2133895
-live_blocks: 33351
-free_words: 2564119
-free_blocks: 19273
-largest_free: 1793
-fragments: 98
-compactions: 0
-
-minor_words: 64028127
-promoted_words: 63367620
-major_words: 63545093
-minor_collections: 1953
-major_collections: 74
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2138085
-live_blocks: 33351
-free_words: 2559920
-free_blocks: 19111
-largest_free: 1800
-fragments: 107
-compactions: 0
-
-minor_words: 70438812
-promoted_words: 69698963
-major_words: 69904882
-minor_collections: 2148
-major_collections: 80
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2131008
-live_blocks: 33351
-free_words: 2566995
-free_blocks: 19079
-largest_free: 1451
-fragments: 109
-compactions: 0
-
-minor_words: 76852923
-promoted_words: 76032234
-major_words: 76270123
-minor_collections: 2343
-major_collections: 86
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2135699
-live_blocks: 33351
-free_words: 2562313
-free_blocks: 19201
-largest_free: 2056
-fragments: 100
-compactions: 0
-
-minor_words: 83248665
-promoted_words: 82362663
-major_words: 82613979
-minor_collections: 2538
-major_collections: 92
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2126387
-live_blocks: 33351
-free_words: 2571625
-free_blocks: 19099
-largest_free: 1498
-fragments: 100
-compactions: 0
-
-minor_words: 89636938
-promoted_words: 88694885
-major_words: 88952817
-minor_collections: 2733
-major_collections: 99
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2136754
-live_blocks: 33351
-free_words: 2561246
-free_blocks: 19220
-largest_free: 1697
-fragments: 112
-compactions: 0
-
-minor_words: 96030388
-promoted_words: 95026453
-major_words: 95296004
-minor_collections: 2928
-major_collections: 106
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2126039
-live_blocks: 33351
-free_words: 2571956
-free_blocks: 19250
-largest_free: 1593
-fragments: 117
-compactions: 0
-
-minor_words: 102436652
-promoted_words: 101356198
-major_words: 101649957
-minor_collections: 3123
-major_collections: 113
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2140261
-live_blocks: 33351
-free_words: 2557747
-free_blocks: 19192
-largest_free: 1731
-fragments: 104
-compactions: 0
-
-minor_words: 108832359
-promoted_words: 107686065
-major_words: 107994506
-minor_collections: 3318
-major_collections: 119
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2124817
-live_blocks: 33351
-free_words: 2700160
-free_blocks: 19149
-largest_free: 1617
-fragments: 111
-compactions: 0
-
-minor_words: 115220373
-promoted_words: 114018413
-major_words: 114333086
-minor_collections: 3513
-major_collections: 125
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2124190
-live_blocks: 33351
-free_words: 2700795
-free_blocks: 19303
-largest_free: 1567
-fragments: 103
-compactions: 0
-
-minor_words: 121628396
-promoted_words: 120347328
-major_words: 120688494
-minor_collections: 3708
-major_collections: 131
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2133563
-live_blocks: 33351
-free_words: 2691408
-free_blocks: 19134
-largest_free: 2129
-fragments: 117
-compactions: 0
-
-minor_words: 128038304
-promoted_words: 126675491
-major_words: 127045570
-minor_collections: 3903
-major_collections: 137
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2135379
-live_blocks: 33351
-free_words: 2689601
-free_blocks: 19345
-largest_free: 1699
-fragments: 108
-compactions: 0
-
-minor_words: 134429672
-promoted_words: 133007487
-major_words: 133387404
-minor_collections: 4098
-major_collections: 143
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2127333
-live_blocks: 33351
-free_words: 2697647
-free_blocks: 19276
-largest_free: 1758
-fragments: 108
-compactions: 0
-
-minor_words: 140831438
-promoted_words: 139333508
-major_words: 139733383
-minor_collections: 4293
-major_collections: 149
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2145113
-live_blocks: 33351
-free_words: 2679876
-free_blocks: 19365
-largest_free: 1650
-fragments: 99
-compactions: 0
-
-minor_words: 147229656
-promoted_words: 145661743
-major_words: 146077858
-minor_collections: 4488
-major_collections: 155
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2132556
-live_blocks: 33351
-free_words: 2692441
-free_blocks: 19150
-largest_free: 1431
-fragments: 91
-compactions: 0
-
-minor_words: 153646155
-promoted_words: 152024536
-major_words: 152442636
-minor_collections: 4684
-major_collections: 161
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2130394
-live_blocks: 33351
-free_words: 2694592
-free_blocks: 19164
-largest_free: 1288
-fragments: 102
-compactions: 0
-
-minor_words: 160038986
-promoted_words: 158352855
-major_words: 158781961
-minor_collections: 4879
-major_collections: 167
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2131838
-live_blocks: 33351
-free_words: 2693140
-free_blocks: 19355
-largest_free: 1741
-fragments: 110
-compactions: 0
-
-minor_words: 166458940
-promoted_words: 164714552
-major_words: 165149249
-minor_collections: 5075
-major_collections: 173
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2146731
-live_blocks: 33351
-free_words: 2678258
-free_blocks: 19338
-largest_free: 1951
-fragments: 99
-compactions: 0
-
-minor_words: 172869183
-promoted_words: 171044208
-major_words: 171507681
-minor_collections: 5270
-major_collections: 179
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2130620
-live_blocks: 33351
-free_words: 2694346
-free_blocks: 19355
-largest_free: 1716
-fragments: 122
-compactions: 0
-
-minor_words: 179276123
-promoted_words: 177371439
-major_words: 177859651
-minor_collections: 5465
-major_collections: 185
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2141174
-live_blocks: 33351
-free_words: 2683827
-free_blocks: 19340
-largest_free: 1707
-fragments: 87
-compactions: 0
-
-minor_words: 185681086
-promoted_words: 183702557
-major_words: 184213391
-minor_collections: 5660
-major_collections: 191
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2133699
-live_blocks: 33351
-free_words: 2691284
-free_blocks: 19303
-largest_free: 1557
-fragments: 105
-compactions: 0
-
-minor_words: 192087937
-promoted_words: 190033229
-major_words: 190568763
-minor_collections: 5855
-major_collections: 197
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2133162
-live_blocks: 33351
-free_words: 2691831
-free_blocks: 19299
-largest_free: 1561
-fragments: 95
-compactions: 0
-
-minor_words: 198496824
-promoted_words: 196364203
-major_words: 196926470
-minor_collections: 6050
-major_collections: 203
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2129841
-live_blocks: 33351
-free_words: 2695139
-free_blocks: 19163
-largest_free: 1653
-fragments: 108
-compactions: 0
-
-minor_words: 204889797
-promoted_words: 202693452
-major_words: 203267275
-minor_collections: 6245
-major_collections: 209
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2130715
-live_blocks: 33351
-free_words: 2694271
-free_blocks: 19257
-largest_free: 1491
-fragments: 102
-compactions: 0
-
-minor_words: 211268811
-promoted_words: 208990042
-major_words: 209593734
-minor_collections: 6439
-major_collections: 215
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2128683
-live_blocks: 33351
-free_words: 2696320
-free_blocks: 19306
-largest_free: 1789
-fragments: 85
-compactions: 0
-
-minor_words: 217673548
-promoted_words: 215319820
-major_words: 215946607
-minor_collections: 6634
-major_collections: 221
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2134523
-live_blocks: 33351
-free_words: 2690457
-free_blocks: 19391
-largest_free: 1845
-fragments: 108
-compactions: 0
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=graph_test
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=sorts
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Animation of sorting algorithms. *)
open Graphics
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=graph_example
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Para, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* To run this example:
********************
1. Select all the text in this window.
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
default:
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1995 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let rec tak (x, y, z) =
if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
else z
-# $Id: Makefile 12239 2012-03-14 10:22:02Z xclerc $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+.PHONY: compile
compile: compile-targets
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
include ../makefiles/Makefile.common
+.PHONY: compile-targets
compile-targets: testing.cmi testing.cmo
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
+ @if $(BYTECODE_ONLY); then : ; else \
$(MAKE) testing.cmx; \
fi
(* *)
(***********************************************************************)
-(* $Id: testing.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Testing auxilliaries. *)
open Scanf;;
(* *)
(***********************************************************************)
-(* $Id: testing.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Testing auxilliaries. *)
val test : bool -> unit;;
-# $Id: Makefile.common 12551 2012-06-04 11:40:59Z doligez $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
TOPDIR=$(BASEDIR)/..
+WINTOPDIR=`cygpath -m "$(TOPDIR)"`
-include $(TOPDIR)/config/Makefile
+# TOPDIR is the root directory of the OCaml sources, in Unix syntax.
+# WINTOPDIR is the same directory, in Windows syntax.
+OTOPDIR=$(TOPDIR)
+CTOPDIR=$(TOPDIR)
+CYGPATH=echo
DIFF=diff -q
-BOOTDIR=$(TOPDIR)/boot
-OCAMLRUN=$(BOOTDIR)/ocamlrun$(EXE)
-OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml -I $(TOPDIR)/stdlib
-OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib
-OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib
-OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc
-OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex
-OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib
+CANKILL=true
+SORT=sort
+SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)"
+
+# The variables above may be overridden by .../config/Makefile
+# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+# arguments given to the OCaml compiler.
+# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+# arguments given to the C and Fortran compilers.
+# CYGPATH is the command that translates unix-style file names into
+# whichever syntax is appropriate for arguments of OCaml programs.
+# DIFF is a "diff -q" command that ignores trailing CRs under Windows.
+# CANKILL is true if a script launched by Make can kill an OCaml process,
+# and false for the mingw and MSVC ports.
+# SORT is the Unix "sort" command. Usually a simple command, but may be an
+# absolute name if the Windows "sort" command is in the PATH.
+# SET_LD_PATH is a command prefix that sets the path for dynamic libraries
+# (LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell
+# variable. Note that for Windows we add Unix-syntax directory names in
+# PATH, and Cygwin will translate it to Windows syntax.
+
+include $(TOPDIR)/config/Makefile
+
+OCAMLRUN=$(TOPDIR)/boot/ocamlrun$(EXE)
+
+OCFLAGS=-nostdlib -I $(OTOPDIR)/stdlib $(COMPFLAGS)
+
+OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) \
+ -init $(OTOPDIR)/testsuite/lib/empty
+OCAMLC=$(OCAMLRUN) $(OTOPDIR)/ocamlc $(OCFLAGS)
+OCAMLOPT=$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS)
+OCAMLDOC=$(OCAMLRUN) $(OTOPDIR)/ocamldoc/ocamldoc
+OCAMLLEX=$(OCAMLRUN) $(OTOPDIR)/lex/ocamllex
+OCAMLMKLIB=$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \
+ -ocamlc "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+ $(OTOPDIR)/ocamlc $(OCFLAGS)" \
+ -ocamlopt "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+ $(OTOPDIR)/ocamlopt $(OCFLAGS)"
OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native
-DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj
-BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi`
-#COMPFLAGS=
+DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tool/dumpobj
+BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]
+
#FORTRAN_COMPILER=
#FORTRAN_LIBRARY=
+UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac`
+
defaultpromote:
@for file in *.reference; do \
cp `basename $$file reference`result $$file; \
done
.SUFFIXES:
-.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .o .so
+.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .o .so .c .f
.mli.cmi:
- @$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+ @$(OCAMLC) -c $(ADD_COMPFLAGS) $<
.ml.cmi:
- @$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+ @$(OCAMLC) -c $(ADD_COMPFLAGS) $<
.ml.cmo:
- @if [ -f $<i ]; then $(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<i; fi
- @$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+ @if [ -f $<i ]; then $(OCAMLC) -c $(ADD_COMPFLAGS) $<i; fi
+ @$(OCAMLC) -c $(ADD_COMPFLAGS) $<
.ml.cmx:
- @$(OCAMLOPT) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+ @$(OCAMLOPT) -c $(ADD_COMPFLAGS) $<
.cmx.so:
- @$(OCAMLOPT) -o $@ -shared $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+ @$(OCAMLOPT) -o $@ -shared $(ADD_COMPFLAGS) $<
.cmxa.so:
- @$(OCAMLOPT) -o $@ -shared -linkall $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+ @$(OCAMLOPT) -o $@ -shared -linkall $(ADD_COMPFLAGS) $<
.mly.ml:
@$(OCAMLYACC) -q $< 2> /dev/null
.cmm.o:
@$(OCAMLRUN) ./codegen $*.cmm > $*.s
- @$(AS) $(ASFLAGS) -o $*.o $*.s
+ @$(ASM) -o $*.o $*.s
.S.o:
@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.S
.s.o:
@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.s
+
+.c.o:
+ @$(CC) -c -I$(CTOPDIR)/byterun $*.c -o $*.$(O)
+
+.f.o:
+ @$(FORTRAN_COMPILER) -c -I$(CTOPDIR)/byterun $*.f -o $*.$(O)
-# $Id: Makefile.okbad 11965 2011-12-28 08:47:03Z xleroy $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+.PHONY: default
default: compile
+.PHONY: compile
compile:
@for file in *.ml; do \
printf " ... testing '$$file'"; \
if [ `echo $$file | grep bad` ]; then \
- $(OCAMLC) -c -w a $$file 2> /dev/null && (echo " => failed" && exit 1) || echo " => passed"; \
+ $(OCAMLC) -c -w a $$file 2>/dev/null \
+ && echo " => failed" || echo " => passed"; \
else \
- test -f `basename $$file ml`mli && $(OCAMLC) -c -w a `basename $$file ml`mli; \
- $(OCAMLC) -c -w a $$file 2> /dev/null || (echo " => failed" && exit 1); \
- test -f `basename $$file ml`reference && $(OCAMLC) `basename $$file ml`cmo && ./a.out > `basename $$file ml`result && ($(DIFF) `basename $$file ml`reference `basename $$file ml`result || (echo " => failed" && exit 1)); \
- echo " => passed"; \
+ F="`basename $$file .ml`"; \
+ test -f $$F.mli && $(OCAMLC) -c -w a $$F.mli; \
+ $(OCAMLC) -c -w a $$file 2>/dev/null \
+ && if [ -f $$F.reference ]; then \
+ rm -f program.byte; \
+ $(OCAMLC) $$F.cmo -o program.byte \
+ && $(OCAMLRUN) program.byte >$$F.result \
+ && $(DIFF) $$F.reference $$F.result >/dev/null; \
+ fi \
+ && echo " => passed" || echo " => failed"; \
fi; \
done
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f ./a.out *.cm* *.result
+ @rm -f program.byte *.cm* *.result
-# $Id: Makefile.one 12649 2012-06-27 12:29:20Z doligez $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
CMI_FILES=$(MODULES:=.cmi)
CMO_FILES=$(MODULES:=.cmo)
ML_YACC_FILES=$(YACC_MODULES:=.ml)
MLI_YACC_FILES=$(YACC_MODULES:=.mli)
ML_FILES=$(ML_LEX_FILES) $(ML_YACC_FILES)
-O_FILES=$(C_FILES:=.o)
+O_FILES=$(C_FILES:=.$(O))
ADD_CMO_FILES=$(ADD_MODULES:=.cmo)
ADD_CMX_FILES=$(ADD_MODULES:=.cmx)
GENERATED_SOURCES=$(ML_LEX_FILES) $(ML_YACC_FILES) $(MLI_YACC_FILES)
-CUSTOM_FLAG=`if [ -z "$(C_FILES)" ]; then true; else echo '-custom'; fi`
+CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
ADD_CFLAGS+=$(CUSTOM_FLAG)
+MYRUNTIME=`if [ -z "$(C_FILES)" ]; then echo '$(OCAMLRUN)'; fi`
-default: compile run
+CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
+.PHONY: default
+default:
+ @$(SET_LD_PATH) $(MAKE) compile run
+
+.PHONY: compile
compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo
@for file in $(C_FILES); do \
- $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \
+ $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(CTOPDIR)/byterun $$file.c; \
done;
@rm -f program.byte program.byte.exe
- @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
+ @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
+ $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+ $(MAIN_MODULE).cmo
+ @if $(BYTECODE_ONLY); then : ; else \
rm -f program.native program.native.exe; \
$(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \
- $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \
+ $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native$(EXE) $(O_FILES) \
+ $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) \
+ $(MAIN_MODULE).cmx; \
fi
+.PHONY: run
run:
@printf " ... testing with ocamlc"
- @./program.byte $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1)
- @$(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1)
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
- printf " ocamlopt"; \
- ./program.native $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1); \
- $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1); \
- fi
- @echo " => passed"
+ @$(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) >$(MAIN_MODULE).result\
+ && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
+ && if $(BYTECODE_ONLY); then : ; else \
+ printf " ocamlopt"; \
+ ./program.native$(EXE) $(EXEC_ARGS) > $(MAIN_MODULE).result \
+ && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
+ >/dev/null; \
+ fi \
+ && echo " => passed" || echo " => failed"
+
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f *.result ./program.* $(GENERATED_SOURCES) $(O_FILES)
+ @rm -f *.result program.byte program.byte.exe \
+ program.native program.native.exe \
+ $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
-# $Id: Makefile.several 12618 2012-06-19 14:17:41Z doligez $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
FC=$(FORTAN_COMPILER)
CMXA_FILES=$(LIBRARIES:=.cmxa)
O_FILES=$(C_FILES:=.o)
-CUSTOM_FLAG=`if [ -z "$(C_FILES)" ]; then true; else echo '-custom'; fi`
+CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
ADD_CFLAGS+=$(CUSTOM_FLAG)
-FORTRAN_LIB=`if [ -z "$(F_FILES)" ]; then true; else echo '$(FORTRAN_LIBRARY)'; fi`
+MYRUNTIME=`if [ -z "$(C_FILES)" ]; then echo '$(OCAMLRUN)'; fi`
+FORTRAN_LIB=`if [ -n "$(F_FILES)" ]; then echo '$(FORTRAN_LIBRARY)'; fi`
ADD_CFLAGS+=$(FORTRAN_LIB)
ADD_OPTFLAGS+=$(FORTRAN_LIB)
+.PHONY: check
check:
- @if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then $(MAKE) run-all; fi
+ @if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then \
+ $(SET_LD_PATH) $(MAKE) run-all; \
+ fi
+.PHONY: run-all
run-all:
@for file in $(C_FILES); do \
$(CC) -c -I$(PREFIX)/lib/ocaml/caml $$file.c; \
$(FORTRAN_COMPILER) -c -I$(PREFIX)/lib/ocaml/caml $$file.f; \
done;
@for file in *.ml; do \
+ if [ -f `basename $$file ml`precheck ]; then \
+ CANKILL=$(CANKILL) sh `basename $$file ml`precheck || continue; \
+ fi; \
printf " ... testing '$$file':"; \
- $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) -w a $(CMA_FILES) -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
- if [ -z "$(BYTECODE_ONLY)" ]; then \
- $(MAKE) run-file DESC=ocamlopt COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) $(O_FILES) -w a $(CMXA_FILES) -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \
- fi && \
- if [ ! -z $(UNSAFE) ]; then \
- $(MAKE) run-file DESC=ocamlc-unsafe COMP=$(PREFIX)/bin/ocamlc COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file && \
- if [ -z "$(BYTECODE_ONLY)" ]; then \
- $(MAKE) run-file DESC=ocamlopt-unsafe COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file; \
- fi; \
- fi && \
- echo " => passed"; \
- done;
+ $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' \
+ RUNTIME='$(MYRUNTIME)' \
+ COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) \
+ $(CMA_FILES) -I $(OTOPDIR)/testsuite/lib \
+ $(CMO_FILES)' \
+ FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) \
+ && \
+ if $(BYTECODE_ONLY); then : ; else \
+ $(MAKE) run-file DESC=ocamlopt COMP='$(OCAMLOPT)' \
+ RUNTIME= \
+ COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_OPTFLAGS) \
+ $(O_FILES) $(CMXA_FILES) \
+ -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
+ FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \
+ fi \
+ && \
+ if [ -n "$(UNSAFE)" ]; then \
+ $(MAKE) run-file DESC=ocamlc-unsafe COMP='$(OCAMLC)' \
+ RUNTIME='$(MYRUNTIME)' \
+ COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_CFLAGS) \
+ $(O_FILES) $(CMA_FILES) \
+ -I $(OTOPDIR)/testsuite/lib $(CMO_FILES)' \
+ FILE=$$file \
+ && \
+ if $(BYTECODE_ONLY); then : ; else \
+ $(MAKE) run-file DESC=ocamlopt-unsafe COMP='$(OCAMLOPT)' \
+ RUNTIME= \
+ COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_OPTFLAGS)\
+ $(O_FILES) $(CMXA_FILES) \
+ -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
+ FILE=$$file; \
+ fi; \
+ fi \
+ && echo " => passed" || echo " => failed"; \
+ done
+.PHONY: run-file
run-file:
@printf " $(DESC)"
@rm -f program program.exe
- @$(COMP) $(COMPFLAGS) $(FILE) -o program
- @if [ -f `basename $(FILE) ml`runner ]; then \
- sh `basename $(FILE) ml`runner; \
+ @$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
+ @F="`basename $(FILE) .ml`"; \
+ if [ -f $$F.runner ]; then \
+ RUNTIME="$(RUNTIME)" sh $$F.runner; \
else \
- ./program $(PROGRAM_ARGS) > `basename $(FILE) ml`result; \
- fi || (echo " => failed" && exit 1)
- @if [ -f `basename $(FILE) ml`checker ]; then \
- sh `basename $(FILE) ml`checker; \
+ $(RUNTIME) ./program$(EXE) $(PROGRAM_ARGS) >$$F.result; \
+ fi \
+ && \
+ if [ -f $$F.checker ]; then \
+ DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker; \
else \
- $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null; \
- fi || (echo " => failed" && exit 1)
+ $(DIFF) $$F.reference $$F.result >/dev/null; \
+ fi
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f *.result ./program program.exe
+ @rm -f *.result program program.exe
-# $Id: Makefile.toplevel 11965 2011-12-28 08:47:03Z xleroy $
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
default:
@for file in *.ml; do \
- $(OCAML) < $$file 2>&1 | grep -v '^ OCaml version' > $$file.result; \
+ $(OCAML) $(TOPFLAGS) <$$file 2>&1 \
+ | grep -v '^ OCaml version' > $$file.result; \
if [ -f $$file.principal.reference ]; then \
- $(OCAML) -principal < $$file 2>&1 | grep -v '^ OCaml version' > $$file.principal.result; \
+ $(OCAML) $(TOPFLAGS) -principal <$$file 2>&1 \
+ | grep -v '^ OCaml version' > $$file.principal.result; \
fi; \
done
@for file in *.reference; do \
printf " ... testing '$$file':"; \
- $(DIFF) $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \
+ $(DIFF) $$file `basename $$file reference`result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
done
promote: defaultpromote
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+function check() {
+ if (!in_test){
+ printf("error at line %d: found test result without test start\n", NR);
+ errored = 1;
+ }
+}
+
+function clear() {
+ curfile = "";
+ in_test = 0;
+}
+
+function record_pass() {
+ check();
+ ++ passed;
+ clear();
+}
+
+function record_skip() {
+ check();
+ ++ skipped;
+ clear();
+}
+
+function record_fail() {
+ check();
+ ++ failed;
+ fail[failidx++] = sprintf ("%s/%s", curdir, curfile);
+ clear();
+}
+
+function record_unexp() {
+ ++ unexped;
+ unexp[unexpidx++] = sprintf ("%s/%s", curdir, curfile);
+ clear();
+}
+
+/Running tests from '[^']*'/ {
+ if (in_test) record_unexp();
+ match($0, /Running tests from '[^']*'/);
+ curdir = substr($0, RSTART+20, RLENGTH - 21);
+ curfile = "";
+}
+
+/ ... testing.* ... testing/ {
+ printf("error at line %d: found two test results on the same line\n", NR);
+ errored = 1;
+}
+
+/^ ... testing '[^']*'/ {
+ if (in_test) record_unexp();
+ match($0, /... testing '[^']*'/);
+ curfile = substr($0, RSTART+13, RLENGTH-14);
+ in_test = 1;
+}
+
+/^ ... testing with / {
+ if (in_test) record_unexp();
+ in_test = 1;
+}
+
+/=> passed/ {
+ record_pass();
+}
+
+/=> skipped/ {
+ record_skip();
+}
+
+/=> failed/ {
+ record_fail();
+}
+
+/=> unexpected error/ {
+ record_unexp();
+}
+
+# Not displaying "skipped" for the moment, as most of the skipped tests
+# print nothing at all and are not counted.
+
+END {
+ if (errored){
+ printf ("\n#### Some fatal error occurred during testing.\n\n");
+ exit (3);
+ }else{
+ printf("\n");
+ printf("Summary:\n");
+ printf(" %3d test(s) passed\n", passed);
+ printf(" %3d test(s) failed\n", failed);
+ printf(" %3d unexpected error(s)\n", unexped);
+ if (failed != 0){
+ printf("\nList of failed tests:\n");
+ for (i=0; i < failed; i++) printf(" %s\n", fail[i]);
+ }
+ if (unexped != 0){
+ printf("\nList of unexpected errors:\n");
+ for (i=0; i < unexped; i++) printf(" %s\n", unexp[i]);
+ }
+ printf("\n");
+ if (failed || unexped){
+ printf("#### Some tests failed. Exiting with error status.\n\n");
+ exit 4;
+ }
+ }
+}
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
CC=$(NATIVECC)
CFLAGS=$(NATIVECCCOMPOPTS) -g
INCLUDES=\
- -I $(TOPDIR)/utils \
- -I $(TOPDIR)/typing \
- -I $(TOPDIR)/bytecomp \
- -I $(TOPDIR)/asmcomp
+ -I $(OTOPDIR)/utils \
+ -I $(OTOPDIR)/typing \
+ -I $(OTOPDIR)/bytecomp \
+ -I $(OTOPDIR)/asmcomp
OTHEROBJS=\
- $(TOPDIR)/utils/misc.cmo \
- $(TOPDIR)/utils/tbl.cmo \
- $(TOPDIR)/utils/config.cmo \
- $(TOPDIR)/utils/clflags.cmo \
- $(TOPDIR)/utils/terminfo.cmo \
- $(TOPDIR)/utils/ccomp.cmo \
- $(TOPDIR)/utils/warnings.cmo \
- $(TOPDIR)/utils/consistbl.cmo \
- $(TOPDIR)/parsing/location.cmo \
- $(TOPDIR)/parsing/longident.cmo \
- $(TOPDIR)/parsing/syntaxerr.cmo \
- $(TOPDIR)/parsing/parser.cmo \
- $(TOPDIR)/parsing/lexer.cmo \
- $(TOPDIR)/parsing/parse.cmo \
- $(TOPDIR)/parsing/printast.cmo \
- $(TOPDIR)/typing/ident.cmo \
- $(TOPDIR)/typing/path.cmo \
- $(TOPDIR)/typing/primitive.cmo \
- $(TOPDIR)/typing/types.cmo \
- $(TOPDIR)/typing/btype.cmo \
- $(TOPDIR)/typing/oprint.cmo \
- $(TOPDIR)/typing/subst.cmo \
- $(TOPDIR)/typing/predef.cmo \
- $(TOPDIR)/typing/datarepr.cmo \
- $(TOPDIR)/typing/cmi_format.cmo \
- $(TOPDIR)/typing/env.cmo \
- $(TOPDIR)/typing/typedtree.cmo \
- $(TOPDIR)/typing/ctype.cmo \
- $(TOPDIR)/typing/printtyp.cmo \
- $(TOPDIR)/typing/includeclass.cmo \
- $(TOPDIR)/typing/mtype.cmo \
- $(TOPDIR)/typing/includecore.cmo \
- $(TOPDIR)/typing/includemod.cmo \
- $(TOPDIR)/typing/parmatch.cmo \
- $(TOPDIR)/typing/typetexp.cmo \
- $(TOPDIR)/typing/cmt_format.cmo \
- $(TOPDIR)/typing/stypes.cmo \
- $(TOPDIR)/typing/typecore.cmo \
- $(TOPDIR)/typing/typedecl.cmo \
- $(TOPDIR)/typing/typeclass.cmo \
- $(TOPDIR)/typing/typemod.cmo \
- $(TOPDIR)/bytecomp/lambda.cmo \
- $(TOPDIR)/bytecomp/printlambda.cmo \
- $(TOPDIR)/bytecomp/typeopt.cmo \
- $(TOPDIR)/bytecomp/switch.cmo \
- $(TOPDIR)/bytecomp/matching.cmo \
- $(TOPDIR)/bytecomp/translobj.cmo \
- $(TOPDIR)/bytecomp/translcore.cmo \
- $(TOPDIR)/bytecomp/translclass.cmo \
- $(TOPDIR)/bytecomp/translmod.cmo \
- $(TOPDIR)/bytecomp/simplif.cmo \
- $(TOPDIR)/bytecomp/runtimedef.cmo \
- $(TOPDIR)/asmcomp/arch.cmo \
- $(TOPDIR)/asmcomp/debuginfo.cmo \
- $(TOPDIR)/asmcomp/cmm.cmo \
- $(TOPDIR)/asmcomp/printcmm.cmo \
- $(TOPDIR)/asmcomp/reg.cmo \
- $(TOPDIR)/asmcomp/mach.cmo \
- $(TOPDIR)/asmcomp/proc.cmo \
- $(TOPDIR)/asmcomp/clambda.cmo \
- $(TOPDIR)/asmcomp/compilenv.cmo \
- $(TOPDIR)/asmcomp/closure.cmo \
- $(TOPDIR)/asmcomp/cmmgen.cmo \
- $(TOPDIR)/asmcomp/printmach.cmo \
- $(TOPDIR)/asmcomp/selectgen.cmo \
- $(TOPDIR)/asmcomp/selection.cmo \
- $(TOPDIR)/asmcomp/comballoc.cmo \
- $(TOPDIR)/asmcomp/liveness.cmo \
- $(TOPDIR)/asmcomp/spill.cmo \
- $(TOPDIR)/asmcomp/split.cmo \
- $(TOPDIR)/asmcomp/interf.cmo \
- $(TOPDIR)/asmcomp/coloring.cmo \
- $(TOPDIR)/asmcomp/reloadgen.cmo \
- $(TOPDIR)/asmcomp/reload.cmo \
- $(TOPDIR)/asmcomp/printlinear.cmo \
- $(TOPDIR)/asmcomp/linearize.cmo \
- $(TOPDIR)/asmcomp/schedgen.cmo \
- $(TOPDIR)/asmcomp/scheduling.cmo \
- $(TOPDIR)/asmcomp/emitaux.cmo \
- $(TOPDIR)/asmcomp/emit.cmo \
- $(TOPDIR)/asmcomp/asmgen.cmo
+ $(OTOPDIR)/utils/misc.cmo \
+ $(OTOPDIR)/utils/tbl.cmo \
+ $(OTOPDIR)/utils/config.cmo \
+ $(OTOPDIR)/utils/clflags.cmo \
+ $(OTOPDIR)/utils/terminfo.cmo \
+ $(OTOPDIR)/utils/ccomp.cmo \
+ $(OTOPDIR)/utils/warnings.cmo \
+ $(OTOPDIR)/utils/consistbl.cmo \
+ $(OTOPDIR)/parsing/location.cmo \
+ $(OTOPDIR)/parsing/longident.cmo \
+ $(OTOPDIR)/parsing/syntaxerr.cmo \
+ $(OTOPDIR)/parsing/parser.cmo \
+ $(OTOPDIR)/parsing/lexer.cmo \
+ $(OTOPDIR)/parsing/parse.cmo \
+ $(OTOPDIR)/parsing/printast.cmo \
+ $(OTOPDIR)/typing/ident.cmo \
+ $(OTOPDIR)/typing/path.cmo \
+ $(OTOPDIR)/typing/primitive.cmo \
+ $(OTOPDIR)/typing/types.cmo \
+ $(OTOPDIR)/typing/btype.cmo \
+ $(OTOPDIR)/typing/oprint.cmo \
+ $(OTOPDIR)/typing/subst.cmo \
+ $(OTOPDIR)/typing/predef.cmo \
+ $(OTOPDIR)/typing/datarepr.cmo \
+ $(OTOPDIR)/typing/cmi_format.cmo \
+ $(OTOPDIR)/typing/env.cmo \
+ $(OTOPDIR)/typing/typedtree.cmo \
+ $(OTOPDIR)/typing/ctype.cmo \
+ $(OTOPDIR)/typing/printtyp.cmo \
+ $(OTOPDIR)/typing/includeclass.cmo \
+ $(OTOPDIR)/typing/mtype.cmo \
+ $(OTOPDIR)/typing/includecore.cmo \
+ $(OTOPDIR)/typing/includemod.cmo \
+ $(OTOPDIR)/typing/parmatch.cmo \
+ $(OTOPDIR)/typing/typetexp.cmo \
+ $(OTOPDIR)/typing/typedtreeMap.cmo \
+ $(OTOPDIR)/typing/cmt_format.cmo \
+ $(OTOPDIR)/typing/stypes.cmo \
+ $(OTOPDIR)/typing/typecore.cmo \
+ $(OTOPDIR)/typing/typedecl.cmo \
+ $(OTOPDIR)/typing/typeclass.cmo \
+ $(OTOPDIR)/typing/typemod.cmo \
+ $(OTOPDIR)/bytecomp/lambda.cmo \
+ $(OTOPDIR)/bytecomp/printlambda.cmo \
+ $(OTOPDIR)/bytecomp/typeopt.cmo \
+ $(OTOPDIR)/bytecomp/switch.cmo \
+ $(OTOPDIR)/bytecomp/matching.cmo \
+ $(OTOPDIR)/bytecomp/translobj.cmo \
+ $(OTOPDIR)/bytecomp/translcore.cmo \
+ $(OTOPDIR)/bytecomp/translclass.cmo \
+ $(OTOPDIR)/bytecomp/translmod.cmo \
+ $(OTOPDIR)/bytecomp/simplif.cmo \
+ $(OTOPDIR)/bytecomp/runtimedef.cmo \
+ $(OTOPDIR)/asmcomp/arch.cmo \
+ $(OTOPDIR)/asmcomp/debuginfo.cmo \
+ $(OTOPDIR)/asmcomp/cmm.cmo \
+ $(OTOPDIR)/asmcomp/printcmm.cmo \
+ $(OTOPDIR)/asmcomp/reg.cmo \
+ $(OTOPDIR)/asmcomp/mach.cmo \
+ $(OTOPDIR)/asmcomp/proc.cmo \
+ $(OTOPDIR)/asmcomp/clambda.cmo \
+ $(OTOPDIR)/asmcomp/compilenv.cmo \
+ $(OTOPDIR)/asmcomp/closure.cmo \
+ $(OTOPDIR)/asmcomp/cmmgen.cmo \
+ $(OTOPDIR)/asmcomp/printmach.cmo \
+ $(OTOPDIR)/asmcomp/selectgen.cmo \
+ $(OTOPDIR)/asmcomp/selection.cmo \
+ $(OTOPDIR)/asmcomp/comballoc.cmo \
+ $(OTOPDIR)/asmcomp/liveness.cmo \
+ $(OTOPDIR)/asmcomp/spill.cmo \
+ $(OTOPDIR)/asmcomp/split.cmo \
+ $(OTOPDIR)/asmcomp/interf.cmo \
+ $(OTOPDIR)/asmcomp/coloring.cmo \
+ $(OTOPDIR)/asmcomp/reloadgen.cmo \
+ $(OTOPDIR)/asmcomp/reload.cmo \
+ $(OTOPDIR)/asmcomp/printlinear.cmo \
+ $(OTOPDIR)/asmcomp/linearize.cmo \
+ $(OTOPDIR)/asmcomp/schedgen.cmo \
+ $(OTOPDIR)/asmcomp/scheduling.cmo \
+ $(OTOPDIR)/asmcomp/emitaux.cmo \
+ $(OTOPDIR)/asmcomp/emit.cmo \
+ $(OTOPDIR)/asmcomp/printclambda.cmo \
+ $(OTOPDIR)/asmcomp/asmgen.cmo
OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo
ADD_COMPFLAGS=$(INCLUDES) -g
default:
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
+ @if $(BYTECODE_ONLY) || [ -z "$(ASPP)" ]; then : ; else \
$(MAKE) all; \
fi
done
one:
- @$(CC) -o $(NAME).out $(ARGS_$(NAME)) $(NAME).o $(ARCH).o || (echo " => failed" && exit 1)
- @echo " => passed"
+ @$(CC) -o $(NAME).out $(ARGS_$(NAME)) $(NAME).o $(ARCH).o \
+ && echo " => passed" || echo " => failed"
clean: defaultclean
@rm -f ./codegen *.out
/* */
/***********************************************************************/
-/* $Id: alpha.S 11156 2011-07-27 14:17:02Z doligez $ */
-
.globl call_gen_code
.ent call_gen_code
/* */
/***********************************************************************/
-/* $Id: amd64.S 12800 2012-07-30 18:59:07Z doligez $ */
-
#ifdef SYS_macosx
#define ALIGN 4
#else
#ifdef SYS_macosx
.literal16
+#elif defined(SYS_mingw64)
+ .section .rodata.cst8
#else
.section .rodata.cst8,"aM",@progbits,8
#endif
(* *)
(***********************************************************************)
-(* $Id: arith.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Regression test for arithmetic instructions *)
(function "testarith" ()
/* */
/***********************************************************************/
-/* $Id: arm.S 12800 2012-07-30 18:59:07Z doligez $ */
-
.text
.global call_gen_code
(* *)
(***********************************************************************)
-(* $Id: checkbound.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
(function "checkbound2" (x: int y: int)
(checkbound x y))
(* *)
(***********************************************************************)
-(* $Id: fib.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "fib" (n: int)
(if (< n 2)
1
;* *
;*********************************************************************
-; $Id: hppa.S 12800 2012-07-30 18:59:07Z doligez $
; Must be preprocessed by cpp
#ifdef SYS_hpux
/* */
/***********************************************************************/
-/* $Id: i386.S 12649 2012-06-27 12:29:20Z doligez $ */
-
/* Linux with ELF binaries does not prefix identifiers with _.
Linux with a.out binaries, FreeBSD, and NextStep do. */
; ;
;*********************************************************************;
-; $Id: i386nt.asm 12800 2012-07-30 18:59:07Z doligez $
-
.386
.MODEL FLAT
/* */
/***********************************************************************/
-/* $Id: ia64.S 12149 2012-02-10 16:15:24Z doligez $ */
-
#define ST8OFF(a,b,d) st8 [a] = b, d
#define LD8OFF(a,b,d) ld8 a = [b], d
#define STFDOFF(a,b,d) stfd [a] = b, d
(* *)
(***********************************************************************)
-(* $Id: integr.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "square" (x: float)
( *f x x))
(* *)
(***********************************************************************)
-(* $Id: lexcmm.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
val token: Lexing.lexbuf -> Parsecmm.token
type error =
(* *)
(***********************************************************************)
-(* $Id: lexcmm.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
{
open Parsecmm
|* *
|***********************************************************************
-| $Id: m68k.S 12800 2012-07-30 18:59:07Z doligez $
-
| call_gen_code is used with the following types:
| unit -> int
| int -> int
/* */
/***********************************************************************/
-/* $Id: main.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
(* *)
(***********************************************************************)
-(* $Id: main.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Clflags
let compile_file filename =
let lb = Lexing.from_channel ic in
try
while true do
- Asmgen.compile_phrase Format.std_formatter (Parsecmm.phrase Lexcmm.token lb)
+ Asmgen.compile_phrase Format.std_formatter
+ (Parsecmm.phrase Lexcmm.token lb)
done
with
End_of_file ->
/* */
/***********************************************************************/
-/* $Id: mainarith.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include <stdio.h>
#include <math.h>
#include <time.h>
#include <stdlib.h>
#include <string.h>
+#include "../../../byterun/config.h"
+#define FMT ARCH_INTNAT_PRINTF_FORMAT
+
void caml_ml_array_bound_error(void)
{
fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
exit(2);
}
-long R[200];
+intnat R[200];
double D[40];
-long X, Y;
+intnat X, Y;
double F, G;
#define INTTEST(arg,res) \
- { long result = (res); \
+ { intnat result = (res); \
if (arg != result) \
- printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %ld, expected %ld\n", \
+ printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %"FMT"d, expected %"FMT"d\n", \
#arg, #res, X, Y, arg, result); \
}
#define INTFLOATTEST(arg,res) \
- { long result = (res); \
+ { intnat result = (res); \
if (arg != result) \
- printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %ld, expected %ld\n", \
+ printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %"FMT"d, expected %"FMT"d\n", \
#arg, #res, F, G, arg, result); \
}
#define FLOATTEST(arg,res) \
#define FLOATINTTEST(arg,res) \
{ double result = (res); \
if (arg < result || arg > result) \
- printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %.15g, expected %.15g\n", \
+ printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %.15g, expected %.15g\n", \
#arg, #res, X, Y, arg, result); \
}
INTTEST(R[10], (X + 1));
INTTEST(R[11], (X + -1));
- INTTEST(R[12], ((long) ((char *)R + 8)));
- INTTEST(R[13], ((long) ((char *)R + Y)));
+ INTTEST(R[12], ((intnat) ((char *)R + 8)));
+ INTTEST(R[13], ((intnat) ((char *)R + Y)));
INTTEST(R[14], (X - Y));
INTTEST(R[15], (X - 1));
INTTEST(R[16], (X - -1));
- INTTEST(R[17], ((long) ((char *)R - 8)));
- INTTEST(R[18], ((long) ((char *)R - Y)));
+ INTTEST(R[17], ((intnat) ((char *)R - 8)));
+ INTTEST(R[18], ((intnat) ((char *)R - Y)));
INTTEST(R[19], (X * 2));
INTTEST(R[20], (2 * X));
INTTEST(R[43], (X << 1));
INTTEST(R[44], (X << 8));
- INTTEST(R[45], ((unsigned long) X >> Y));
- INTTEST(R[46], ((unsigned long) X >> 1));
- INTTEST(R[47], ((unsigned long) X >> 8));
+ INTTEST(R[45], ((uintnat) X >> Y));
+ INTTEST(R[46], ((uintnat) X >> 1));
+ INTTEST(R[47], ((uintnat) X >> 8));
INTTEST(R[48], (X >> Y));
INTTEST(R[49], (X >> 1));
INTFLOATTEST(R[86], (F >= G));
FLOATINTTEST(D[19], (double) X);
- INTFLOATTEST(R[87], (long) F);
+ INTFLOATTEST(R[87], (intnat) F);
INTTEST(R[88], (X >= 0) && (X < Y));
INTTEST(R[89], (0 < Y));
INTFLOATTEST(R[114], (F + 1.0 >= G));
FLOATINTTEST(D[20], ((double) X) + 1.0);
- INTFLOATTEST(R[115], (long)(F + 1.0));
+ INTFLOATTEST(R[115], (intnat)(F + 1.0));
FLOATTEST(D[21], F + G);
FLOATTEST(D[22], G + F);
/* */
/***********************************************************************/
-/* $Id: mips.s 11156 2011-07-27 14:17:02Z doligez $ */
-
.globl call_gen_code
.ent call_gen_code
call_gen_code:
/* */
/***********************************************************************/
-/* $Id: parsecmm.mly 12800 2012-07-30 18:59:07Z doligez $ */
-
/* A simple parser for C-- */
%{
(* *)
(***********************************************************************)
-(* $Id: parsecmmaux.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Auxiliary functions for parsing *)
type error =
(* *)
(***********************************************************************)
-(* $Id: parsecmmaux.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Auxiliary functions for parsing *)
val bind_ident: string -> Ident.t
#* *
#*********************************************************************
-# $Id: power-aix.S 12149 2012-02-10 16:15:24Z doligez $
-
.csect .text[PR]
.globl .call_gen_code
/* */
/*********************************************************************/
-/* $Id: power-elf.S 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Save and restore all callee-save registers */
/* GPR 14 at sp+16 ... GPR 31 at sp+84
FPR 14 at sp+92 ... FPR 31 at sp+228 */
/* */
/*********************************************************************/
-/* $Id: power-rhapsody.S 11156 2011-07-27 14:17:02Z doligez $ */
-
/* Save and restore all callee-save registers */
/* GPR 14 at sp+16 ... GPR 31 at sp+84
FPR 14 at sp+92 ... FPR 31 at sp+228 */
(* *)
(***********************************************************************)
-(* $Id: quicksort.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "quicksort" (lo: int hi: int a: addr)
(if (< lo hi)
(let (i lo
(* *)
(***********************************************************************)
-(* $Id: quicksort2.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "cmp" (i: int j: int)
(- i j))
(* *)
(***********************************************************************)
-(* $Id: soli.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
("d1": int 0 int 1
"d2": int 1 int 0
"d3": int 0 int -1
/* */
/***********************************************************************/
-/* $Id: sparc.S 12649 2012-06-27 12:29:20Z doligez $ */
-
#if defined(SYS_solaris) || defined(SYS_elf)
#define Call_gen_code _call_gen_code
#define Caml_c_call _caml_c_call
(* *)
(***********************************************************************)
-(* $Id: tagged-fib.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
(function "fib" (n: int)
(if (< n 5)
3
(* *)
(***********************************************************************)
-(* $Id: tagged-integr.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
("res_square": skip 8)
("h": skip 8)
("x": skip 8)
(* *)
(***********************************************************************)
-(* $Id: tagged-quicksort.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "quick" (lo: int hi: int a: addr)
(if (< lo hi)
(let (i lo
(* *)
(***********************************************************************)
-(* $Id: tagged-tak.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "tak" (x:int y:int z:int)
(if (> x y)
(app "tak" (app "tak" (- x 2) y z int)
(* *)
(***********************************************************************)
-(* $Id: tak.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
(function "tak" (x:int y:int z:int)
(if (> x y)
(app "tak" (app "tak" (- x 1) y z int)
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
-EXECNAME=./program
+EXECNAME=program$(EXE)
+
+ABCDFILES=backtrace.ml
+OTHERFILES=backtrace2.ml raw_backtrace.ml
+
+default:
+ $(MAKE) byte
+ @if $(BYTECODE_ONLY); then : ; else $(MAKE) native; fi
-run-all:
- @for file in *.ml; do \
+.PHONY: byte
+byte:
+ @for file in $(ABCDFILES); do \
+ rm -f program program.exe; \
+ $(OCAMLC) -g -o $(EXECNAME) $$file; \
+ for arg in a b c d ''; do \
+ printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \
+ F="`basename $$file .ml`"; \
+ (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \
+ >$$F.$$arg.byte.result 2>&1; \
+ $(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
+ done; \
+ done
+ @for file in $(OTHERFILES); do \
+ rm -f program program.exe; \
$(OCAMLC) -g -o $(EXECNAME) $$file; \
+ printf " ... testing '$$file' with ocamlc:"; \
+ F="`basename $$file .ml`"; \
+ (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \
+ >$$F.byte.result 2>&1; \
+ $(DIFF) $$F.reference $$F.byte.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
+ done
+
+.PHONY: native
+native:
+ @for file in $(ABCDFILES); do \
+ rm -f program program.exe; \
+ $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
for arg in a b c d ''; do \
- printf " ... testing '$$file' (with argument '$$arg'):"; \
- OCAMLRUNPARAM=b=1 $(EXECNAME) $$arg > `basename $$file ml`$$arg.result 2>&1; \
- $(DIFF) `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+ printf " ... testing '$$file' with ocamlopt and argument '$$arg':"; \
+ F="`basename $$file .ml`"; \
+ (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \
+ >$$F.$$arg.native.result 2>&1; \
+ $(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
done; \
done
+ @for file in $(OTHERFILES); do \
+ rm -f program program.exe; \
+ $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+ printf " ... testing '$$file' with ocamlc:"; \
+ F="`basename $$file .ml`"; \
+ (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \
+ >$$F.native.result 2>&1; \
+ $(DIFF) $$F.reference $$F.native.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
+ done
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f *.result $(EXECNAME)
+ @rm -f *.result program program.exe
include $(BASEDIR)/makefiles/Makefile.common
Fatal error: exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace.ml", line 17, characters 12-24
+Raised by primitive operation at file "backtrace.ml", line 29, characters 12-24
b
Fatal error: exception Backtrace.Error("b")
-Raised at file "backtrace.ml", line 6, characters 21-32
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 10, characters 4-11
-Re-raised at file "backtrace.ml", line 12, characters 68-71
-Called from file "backtrace.ml", line 17, characters 9-25
+Raised at file "backtrace.ml", line 18, characters 21-32
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 22, characters 4-11
+Re-raised at file "backtrace.ml", line 24, characters 68-71
+Called from file "backtrace.ml", line 29, characters 9-25
Fatal error: exception Backtrace.Error("c")
-Raised at file "backtrace.ml", line 13, characters 26-37
-Called from file "backtrace.ml", line 17, characters 9-25
+Raised at file "backtrace.ml", line 25, characters 26-37
+Called from file "backtrace.ml", line 29, characters 9-25
Fatal error: exception Backtrace.Error("d")
-Raised at file "backtrace.ml", line 6, characters 21-32
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 10, characters 4-11
-Called from file "backtrace.ml", line 17, characters 9-25
+Raised at file "backtrace.ml", line 18, characters 21-32
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 22, characters 4-11
+Called from file "backtrace.ml", line 29, characters 9-25
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* A test for stack backtraces *)
exception Error of string
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2008 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* A test for stack backtraces *)
exception Error of string
--- /dev/null
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 18, characters 21-32
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 22, characters 4-11
+Re-raised at file "backtrace2.ml", line 24, characters 68-71
+Called from file "backtrace2.ml", line 29, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 25, characters 26-37
+Called from file "backtrace2.ml", line 29, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 18, characters 21-32
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 22, characters 4-11
+Called from file "backtrace2.ml", line 29, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 29, characters 14-22
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2008 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let rec f msg n =
+ if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+ try
+ f msg 5
+ with Error "a" -> print_string "a"; print_newline(); 0
+ | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+ | Error "c" -> raise (Error "c")
+
+let backtrace args =
+ try
+ ignore (g args.(0)); None
+ with exn ->
+ let exn = Printexc.to_string exn in
+ let trace = Printexc.get_raw_backtrace () in
+ Some (exn, trace)
+
+let run args =
+ match backtrace args with
+ | None -> print_string "No exception\n"
+ | Some (exn, trace) ->
+ begin
+ (* raise another exception to stash the global backtrace *)
+ try ignore (f "c" 5); assert false with Error _ -> ();
+ end;
+ Printf.printf "Uncaught exception %s\n" exn;
+ Printexc.print_raw_backtrace stdout trace
+
+let _ =
+ Printexc.record_backtrace true;
+ run [| "a" |];
+ run [| "b" |];
+ run [| "c" |];
+ run [| "d" |];
+ run [| |]
--- /dev/null
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 18, characters 21-32
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 22, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 24, characters 68-71
+Called from file "raw_backtrace.ml", line 29, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 25, characters 26-37
+Called from file "raw_backtrace.ml", line 29, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 18, characters 21-32
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 22, characters 4-11
+Called from file "raw_backtrace.ml", line 29, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 29, characters 14-22
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=float_record
MAIN_MODULE=tfloat_record
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
type t = float;;
let make f = f;;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
type t = private float;;
val make : float -> t;;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let s = { Float_record.f = Float_record.make 1.0 };;
print_float (Float_record.from s.Float_record.f);;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=io
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test a file copy function *)
let test msg funct f1 f2 =
test "263-byte chunks" (copy_file 263) src testio;
test "4011-byte chunks" (copy_file 4011) src testio;
test "0...8192 byte chunks" (copy_random 8192) src testio;
- test "line per line, short lines" copy_line "/etc/hosts" testio;
+ test "line per line, short lines" copy_line "test-file-short-lines" testio;
make_lines lines;
test "line per line, short and long lines" copy_line lines testio;
test "backwards, 4096-byte chunks" (copy_seek 4096) src testio;
--- /dev/null
+##
+# Host Database
+#
+# localhost is used to configure the loopback interface
+# when the system is booting. Do not change this entry.
+##
+127.0.0.1 localhost
+255.255.255.255 broadcasthost
+::1 localhost
+fe80::1%lo0 localhost
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=wc
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1995 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Counts characters, lines and words in one or several files. *)
let chars = ref 0
-1198 characters, 178 words, 54 lines
+2013 characters, 233 words, 66 lines
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=manyargs
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1995 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let manyargs a b c d e f g h i j k l m n o =
print_string "a = "; print_int a; print_newline();
print_string "b = "; print_int b; print_newline();
manyargs_tail2 0 1;
manyargs_tail3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
-external manyargs_ext: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "manyargs_argv" "manyargs"
+external manyargs_ext:
+ int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int ->
+ int
+ = "manyargs_argv" "manyargs"
let _ =
print_string "external:\n"; flush stdout;
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1995 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include "mlvalues.h"
#include "stdio.h"
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=testing
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test bound checks with ocamlopt *)
let a = [| 0; 1; 2 |]
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2001 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(**************************************************************)
(* This suite tests the pattern-matching compiler *)
(* it should just compile and run. *)
+(*************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Estime, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2009 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(*************************************************************************)
+
(* Dummy substitute function. *)
open Testing;;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1995 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Random
let _ =
(* *)
(*************************************************************************)
-(* $Id: tformat.ml 11156 2011-07-27 14:17:02Z doligez $
+(*
A testbed file for the module Format.
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2006 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Testing;;
open Printf;;
sprintf "%(toto %s titi.\n%).\n"
"Bonjour %s" "toto" = "Bonjour toto.\n" &&
sprintf "%(toto %s titi.\n%)%s\n"
- "Bonjour %s." "toto" " Ça va?" = "Bonjour toto. Ça va?\n"
+ "Bonjour %s." "toto" " Ca va?" = "Bonjour toto. Ca va?\n"
;;
test (test5 ());;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=multdef
MAIN_MODULE=usemultdef
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let f x = x + 1
external g : string -> int = "caml_int_of_string"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
val f : int -> int
val f : int -> int
val g : string -> int
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let _ = print_int(Multdef.f 1); print_newline(); exit 0
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=length
-(* $Id: length.ml 11123 2011-07-20 09:17:07Z doligez $
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(*
A testbed file for private type abbreviation definitions.
-(* $Id: length.mli 11123 2011-07-20 09:17:07Z doligez $
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(*
A testbed file for private type abbreviation definitions.
-(* $Id: tlength.ml 11123 2011-07-20 09:17:07Z doligez $
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(*
A testbed file for private type abbreviation definitions.
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1995 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let bigarray n = [|
n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;
let test5 () =
if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then
print_string "Test5: failed on int arrays\n";
- if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] then
+ if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |]
+ then
print_string "Test5: failed on float arrays\n"
let test6 () =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1997 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let _ =
match Sys.word_size with
| 32 ->
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test the types nativeint, int32, int64 *)
open Printf
test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0"))
(Int32.of_string "0x9ABCDEF0")
else
- test 3 0 0; (* placeholder to have the same output on both 32-bit and 64-bit *)
+ test 3 0 0; (* placeholder to have the same output on 32-bit and 64-bit *)
testing_function "int64 of/to int32";
test 1 (Int64.of_int32 (Int32.of_string "-0x12345678"))
(Int64.of_string "-0x12345678");
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let test n check res =
print_string "Test "; print_int n;
if check res then print_string " passed.\n" else print_string " FAILED.\n";
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Moscova, INRIA Rocqencourt *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2001 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test for "include <module-expr>" inside structures *)
module A =
(* *)
(***********************************************************************)
-(* $Id: maps.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
module IntMap = Map.Make(struct type t = int let compare x y = x-y end)
let m1 = IntMap.add 4 "Y" (IntMap.singleton 3 "X1")
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Tests for matchings on integers and characters *)
(* Dense integer switch *)
printf "l([||]) = %d\n" (l [||]);
printf "l([|1|]) = %d\n" (l [|1|]);
printf "l([|2;3|]) = %d\n" (l [|2;3|]);
- printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|]);
- exit 0
+ printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|])
+
+(* PR #5992 *)
+(* Was segfaulting *)
+
+let f = function
+ | lazy (), _, {contents=None} -> 0
+ | _, lazy (), {contents=Some x} -> 1
+
+let s = ref None
+let set_true = lazy (s := Some 1)
+let set_false = lazy (s := None)
+
+let () =
+ let _r = try f (set_true, set_false, s) with Match_failure _ -> 2 in
+ printf "PR#5992=Ok\n"
l([|1|]) = 2
l([|2;3|]) = 5
l([|4;5;6|]) = 15
+PR#5992=Ok
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Recursive value definitions *)
let _ =
(* *)
(***********************************************************************)
-(* $Id: sets.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let rec tailcall4 a b c d =
if a < 0
then b
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
-CC=$(NATIVECC) -I $(TOPDIR)/byterun
+CC=$(NATIVECC) -I $(CTOPDIR)/byterun
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/unix
+LD_PATH=$(TOPDIR)/otherlibs/unix
-default: run-byte run-opt
+.PHONY: default
+default:
+ @case " $(OTHERLIBRARIES) " in \
+ *' unix '*) $(SET_LD_PATH) $(MAKE) run-byte run-opt;; \
+ esac
+.PHONY: common
common:
@$(CC) -c callbackprim.c
+.PHONY: run-byte
run-byte: common
@printf " ... testing 'bytecode':"
- @$(OCAMLC) -c tcallback.ml
- @$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo
- @./program > bytecode.result
- @$(DIFF) reference bytecode.result || (echo " => failed" && exit 1)
- @echo " => passed"
-
+ @$(OCAMLC) $(COMPFLAGS) -c tcallback.ml
+ @$(OCAMLC) $(COMPFLAGS) -o ./program -custom unix.cma \
+ callbackprim.$(O) tcallback.cmo
+ @./program >bytecode.result
+ @$(DIFF) reference bytecode.result \
+ && echo " => passed" || echo " => failed"
+
+.PHONY: run-opt
run-opt: common
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
+ @if $(BYTECODE_ONLY); then : ; else \
printf " ... testing 'native':"; \
- $(OCAMLOPT) -c tcallback.ml; \
- $(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx; \
- ./program > native.result; \
- $(DIFF) reference native.result || (echo " => failed" && exit 1); \
- echo " => passed"; \
+ $(OCAMLOPT) $(COMPFLAGS) -c tcallback.ml; \
+ $(OCAMLOPT) $(COMPFLAGS) -o ./program unix.cmxa callbackprim.$(O) \
+ tcallback.cmx; \
+ ./program >native.result; \
+ $(DIFF) reference native.result \
+ && echo " => passed" || echo " => failed"; \
fi
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
@rm -f *.result ./program
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1995 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include "mlvalues.h"
#include "memory.h"
#include "callback.h"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1995 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"
-external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3"
-external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
+external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd
+ = "mycallback3"
+external mycallback4 :
+ ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
let rec tak (x, y, z as _tuple) =
if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
+.PHONY: default
default: compile run
-compile:
- @$(OCAMLC) -ccopt -I -ccopt $(TOPDIR)/byterun cmstub.c
- @$(OCAMLC) -ccopt -I -ccopt $(TOPDIR)/byterun cmmain.c
+.PHONY: compile
+compile: caml
+ @$(OCAMLC) -ccopt -I -ccopt . cmstub.c
+ @$(OCAMLC) -ccopt -I -ccopt . cmmain.c
@$(OCAMLC) -c cmcaml.ml
- @$(OCAMLC) -custom -o program cmstub.o cmcaml.cmo cmmain.o
+ @$(OCAMLC) -custom -o program cmstub.$(O) cmcaml.cmo cmmain.$(O)
+
+caml:
+ @mkdir -p caml || :
+ @cp -f $(TOPDIR)/byterun/*.h caml/
+.PHONY: run
run:
@printf " ... testing 'cmmain':"
- @./program > program.result
- @$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1)
- @echo " => passed"
+ @./program >program.result
+ @$(DIFF) program.reference program.result >/dev/null \
+ && echo " => passed" || echo " => failed"
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f *.result ./program
+ @rm -f *.result program
+ @rm -rf caml
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* OCaml part of the code *)
let rec fib n =
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
/* Main program -- in C */
#include <stdlib.h>
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
#include <string.h>
#include <caml/mlvalues.h>
#include <caml/callback.h>
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+MAIN_MODULE=exotic
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2013 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* Exotic OCaml syntax constructs found in the manual that are not *)
+(* used in the source of the OCaml distribution (even in the tests). *)
+
+(* Spaces between the parts of the ?label: token in a typexpr.
+ (used in bin-prot) *)
+type t1 = ? label : int -> int -> int;;
+
+(* Lazy in a pattern. (used in advi) *)
+function lazy y -> y;;
+
+(* Spaces between the parts of the ?label: token in a class-type. *)
+class c1 =
+ (fun ?label:x y -> object end : ? label : int -> int -> object end)
+;;
+
+(* type-class annotation in class-expr *)
+class c2 = (object end : object end);;
+
+(* virtual object field *)
+class virtual c3 = object val virtual x : int end;;
+class virtual c4 = object val mutable virtual x : int end;;
+
+(* abstract module type in a signature *)
+module type T = sig
+ module type U
+end;;
+
+(* associativity rules for patterns *)
+function Some Some x -> x | _ -> 0;;
+function Some `Tag x -> x | _ -> 0;;
+function `Tag Some x -> x | _ -> 0;;
+function `Tag `Tag x -> x | _ -> 0;;
+
+(* negative int32, int64, nativeint constants in patterns *)
+function -1l -> () | _ -> ();;
+function -1L -> () | _ -> ();;
+function -1n -> () | _ -> ();;
+
+(* surprising places where you can use an operator as a variable name *)
+function (+) -> (+);;
+function _ as (+) -> (+);;
+for (+) = 0 to 1 do () done;;
+
+(* access a class-type through an extended-module-path *)
+module F (X : sig end) = struct
+ class type t = object end
+end;;
+module M1 = struct end;;
+class type u = F(M1).t;;
+
+(* conjunctive constraints on tags (used by the compiler to print some
+ inferred types) *)
+type 'a t2 = [< `A of int & int & int ] as 'a;;
+
+(* same for a parameterless tag (triggers a very strange error message) *)
+(*type ('a, 'b) t3 = [< `A of & 'b ] as 'a;;*)
+
+(* negative float constant in a pattern *)
+function -1.0 -> 1 | _ -> 2;;
+
+(* combining language extensions (sec. 7.13 and 7.17) *)
+class c5 = object method f = 1 end;;
+object
+ inherit c5
+ method! f : type t . int = 2
+end;;
+
+(* private polymorphic method with local type *)
+object method private f : type t . int = 1 end;;
+
+
+(* More exotic: not even found in the manual (up to version 4.00),
+ but used in some programs found in the wild.
+*)
+
+(* local functor *)
+let module M (M1 : sig end) = struct end in ();;
+
+(* let-binding with a type coercion *)
+let x :> int = 1;;
+let x : int :> int = 1;;
+
+(* "begin end" as an alias for "()" *)
+begin end;;
+
+(* putting "virtual" before "mutable" or "private" *)
+class type virtual ct = object
+ val mutable virtual x : int
+ val virtual mutable y : int
+ method private virtual f : int
+ method virtual private g : int
+end;;
+class virtual c = object
+ val mutable virtual x : int
+ val virtual mutable y : int
+ method private virtual f : int
+ method virtual private g : int
+end;;
+
+(* Double-semicolon at the beginning of a module body [ocp-indent] *)
+module M2 = struct ;; end;;
+
+
+(**********************
+
+(* Most exotic: not found in the manual (up to 4.00) and not used
+ deliberately by anyone, but still implemented by the compiler. *)
+
+(* whitespace inside val!, method!, inherit! [found in ocamlspot] *)
+object
+ val x = 1
+ val ! x = 2
+ method m = 1
+ method ! m = 2
+ inherit ! object val x = 3 end
+end;;
+
+(* Using () as a constructor name [found in gettext] *)
+type t = ();;
+let x : t = ();;
+
+(* Using :: as a constructor name *)
+type t = :: of int * int;;
+
+(* Prefix syntax for :: in expressions *)
+(::) (1, 1);;
+
+(* Prefix syntax for :: in patterns *)
+function (::) (_, _) -> 1;;
+
+(* Unary plus in expressions (ints and float) *)
++1;;
++1l;;
++1L;;
++1n;;
++1.0;;
+
+(* Unary plus in patterns (ints and floats) *)
+function +1 -> ();;
+function +1l -> ();;
+function +1L -> ();;
+function +1n -> ();;
+function +1.0 -> ();;
+
+**********************)
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=globroots
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2001 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
module type GLOBREF = sig
type t
val register: string -> t
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2001 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
/* For testing global root registration */
#include "mlvalues.h"
value gb_classic_register(value v)
{
- struct block * b = stat_alloc(sizeof(struct block));
+ struct block * b = caml_stat_alloc(sizeof(struct block));
b->v = v;
caml_register_global_root(&(b->v));
return (value) b;
value gb_generational_register(value v)
{
- struct block * b = stat_alloc(sizeof(struct block));
+ struct block * b = caml_stat_alloc(sizeof(struct block));
b->v = v;
caml_register_generational_global_root(&(b->v));
return (value) b;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* testing backreferences; some compilation scheme may handle
differently recursive references to a mutually-recursive RHS
depending on whether it is before or after in the bindings list *)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* class expression are compiled to recursive bindings *)
class test =
object
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* class expressions may also contain local recursive bindings *)
class test =
let rec f = print_endline "f"; fun x -> g x
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* test evaluation order
'y' is translated into a constant, and is therefore considered
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* A variant of evaluation_order_1.ml where the side-effects
are inside the blocks. Note that this changes the evaluation
order, as y is considered recursive.
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
type t = { x : t; y : t }
let p = print_endline
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* a bug in cmmgen.ml provokes a change in compilation order between
ocamlc and ocamlopt in certain letrec-bindings involving float
arrays *)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* a bug in cmmgen.ml provokes a segfault in certain natively compiled
letrec-bindings involving float arrays *)
let test =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* a test with lists, because cyclic lists are fun *)
let test =
let rec li = 0::1::2::3::4::5::6::7::8::9::li in
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* mixing values and closures may exercise interesting code paths *)
type t = A of (int -> int)
let test =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* a polymorphic variant of test3.ml; found a real bug once *)
let test =
let rec x = `A f
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* a simple test with mutually recursive functions *)
let test =
let rec even = function
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+
+(* A regression test for both PR#4141 and PR#5819: when a recursive
+ variable is defined by a { record with ... } expression.
+*)
+
+type t = {
+ self : t;
+ t0 : int;
+ t1 : int;
+ t2 : int;
+ t3 : int;
+ t4 : int;
+};;
+let rec t = {
+ self = t;
+ t0 = 42;
+ t1 = 42;
+ t2 = 42;
+ t3 = 42;
+ t4 = 42;
+};;
+
+let rec self = { t with self=self } in
+Printf.printf "%d\n" self.self.t0
+;;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
LIBRARIES=unix bigarray
C_FILES=bigarrfstub
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Bigarray
open Printf
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2000 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include <stdio.h>
#include <mlvalues.h>
#include <bigarray.h>
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
LIBRARIES=unix bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+ -I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Bigarray
open Printf
open Complex
(* *)
(***********************************************************************)
-(* $Id: fftba.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Bigarray
let pi = 3.14159265358979323846
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2010 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* PR#5115 - multiple evaluation of bigarray expr *)
open Bigarray
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=md5
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2003 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test int32 arithmetic and optimizations using the MD5 algorithm *)
open Printf
custom
custom.exe
marshal.data
+caml
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
-default: compile run
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/dynlink
+LD_PATH=.:$(TOPDIR)/otherlibs/dynlink
+
+.PHONY: default
+default:
+ @$(SET_LD_PATH) $(MAKE) compile run
-compile:
+.PHONY: compile
+compile: caml
@$(OCAMLC) -c registry.ml
@for file in stub*.c; do \
- $(OCAMLC) -c $$file; \
- $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' | sed -e 's/\.c//'` `basename $$file c`o; \
+ $(OCAMLC) -ccopt -I -ccopt . -c $$file; \
+ $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' -e 's/\.c//'` \
+ `basename $$file c`$(O); \
done
@for file in plug*.ml; do \
$(OCAMLC) -c $$file; \
$(OCAMLMKLIB) -o `basename $$file .ml` `basename $$file ml`cmo; \
done
@$(OCAMLC) -c main.ml
+ @rm -f main static custom custom.exe
@$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo
- @$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun
- @$(OCAMLC) -o custom -custom -linkall registry.cmo plug2.cma plug1.cma -I .
+ @$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma \
+ -use-runtime $(OTOPDIR)/boot/ocamlrun$(EXE)
+ @$(OCAMLC) -o custom$(EXE) -custom -linkall registry.cmo plug2.cma \
+ plug1.cma -I .
+
+caml:
+ @mkdir -p caml || :
+ @cp -f $(TOPDIR)/byterun/*.h caml/
+.PHONY: run
run:
@printf " ... testing 'main'"
- @export LD_LIBRARY_PATH=`pwd` && ./main plug1.cma plug2.cma > main.result
- @$(DIFF) main.reference main.result > /dev/null || (echo " => failed" && exit 1)
- @echo " => passed"
+ @$(OCAMLRUN) ./main plug1.cma plug2.cma >main.result
+ @$(DIFF) main.reference main.result >/dev/null \
+ && echo " => passed" || echo " => failed"
@printf " ... testing 'static'"
- @export LD_LIBRARY_PATH=`pwd` && ./static > static.result
- @$(DIFF) static.reference static.result > /dev/null || (echo " => failed" && exit 1)
- @echo " => passed"
+ @$(OCAMLRUN) ./static >static.result
+ @$(DIFF) static.reference static.result >/dev/null \
+ && echo " => passed" || echo " => failed"
@printf " ... testing 'custom'"
- @export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result
- @$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1)
- @echo " => passed"
+ @./custom$(EXE) >custom.result
+ @$(DIFF) custom.reference custom.result >/dev/null \
+ && echo " => passed" || echo " => failed"
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f ./main ./static ./custom *.result marshal.data
+ @rm -f main static custom custom.exe *.result marshal.data
+ @rm -rf caml
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let f x = print_string "This is Main.f\n"; x
let () = Registry.register f
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
external stub1: unit -> string = "stub1"
let f x = print_string "This is Plug1.f\n"; x + 1
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
external stub2: unit -> unit = "stub2"
let f x = print_string "This is Plug2.f\n"; x + 2
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let functions = ref ([]: (int -> int) list)
let register f =
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Alain Frisch, LexiFi */
+/* */
+/* Copyright 2007 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include "caml/mlvalues.h"
#include "caml/memory.h"
#include "caml/alloc.h"
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Alain Frisch, LexiFi */
+/* */
+/* Copyright 2007 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include "caml/mlvalues.h"
#include "caml/memory.h"
#include "caml/alloc.h"
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
CSC=csc
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/bigarray
+
+.PHONY: default
default:
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
- $(MAKE) all; \
+ @if $(BYTECODE_ONLY); then : ; else \
+ $(SET_LD_PATH) $(MAKE) all; \
fi
+.PHONY: all
all: prepare bytecode bytecode-dll native native-dll
+.PHONY: prepare
prepare:
@$(OCAMLC) -c plugin.ml
@$(OCAMLOPT) -o plugin.cmxs -shared plugin.ml
+.PHONY: bytecode
bytecode:
@printf " ... testing 'bytecode':"
- @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
- echo " => passed"; \
+ @if [ ! `which $(CSC) >/dev/null 2>&1` ]; then \
+ echo " => skipped"; \
else \
$(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
$(CSC) /out:main.exe main.cs; \
./main.exe > bytecode.result; \
- $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+ $(DIFF) bytecode.reference bytecode.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
fi
+.PHONY: bytecode-dll
bytecode-dll:
@printf " ... testing 'bytecode-dll':"
@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
- echo " => passed"; \
+ echo " => skipped"; \
else \
$(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \
- $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../byterun/libcamlrun.$(A) $(BYTECCLIBS) -v; \
+ $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
+ ../../byterun/libcamlrun.$(A) $(BYTECCLIBS) -v; \
$(CSC) /out:main.exe main.cs; \
- ./main.exe > bytecode.result; \
- $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+ ./main.exe >bytecode.result; \
+ $(DIFF) bytecode.reference bytecode.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
fi
+.PHONY: native
native:
@printf " ... testing 'native':"
@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
- echo " => passed"; \
+ echo " => skipped"; \
else \
$(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
$(CSC) /out:main.exe main.cs; \
./main.exe > native.result; \
- $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+ $(DIFF) native.reference native.result > /dev/null \
+ && echo " => passed" || echo " => failed"; \
fi
+.PHONY: native-dll
native-dll:
@printf " ... testing 'native-dll':"
@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
- echo " => passed"; \
+ echo " => skipped"; \
else \
- $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c main.ml; \
- $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../asmrun/libasmrun.lib -v; \
+ $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c \
+ main.ml; \
+ $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
+ ../../asmrun/libasmrun.lib -v; \
$(CSC) /out:main.exe main.cs; \
./main.exe > native.result; \
- $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+ $(DIFF) native.reference native.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
fi
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f *.result *.exe *.dll
+ @rm -f *.result *.exe *.dll *.so *.obj *.o
include $(BASEDIR)/makefiles/Makefile.common
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Alain Frisch, LexiFi */
+/* */
+/* Copyright 2007 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <caml/custom.h>
#include <caml/fail.h>
-__declspec(dllexport) void __stdcall start_caml_engine() {
+#if !defined(OPENSTEP) && (defined(__WIN32__) && !defined(__CYGWIN__))
+# if defined(_MSC_VER) || defined(__MINGW32__)
+# define _DLLAPI __declspec(dllexport)
+# else
+# define _DLLAPI extern
+# endif
+# if defined(__MINGW32__) || defined(UNDER_CE)
+# define _CALLPROC
+# else
+# define _CALLPROC __stdcall
+# endif
+#elif defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__) >= 303
+# define _DLLAPI __attribute__((visibility("default")))
+# define _CALLPROC
+#endif /* WIN32 && !CYGWIN */
+
+_DLLAPI void _CALLPROC start_caml_engine() {
char * argv[2];
argv[0] = "--";
argv[1] = NULL;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let load s =
Printf.printf "Loading %s\n%!" s;
try
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let f x = x.{2}
let () =
mypack.pack.s
+mypack.pack.asm
result
main
main.exe
marshal.data
+caml
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+ -I $(OTOPDIR)/otherlibs/systhreads \
+ -I $(OTOPDIR)/otherlibs/dynlink
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/dynlink
+.PHONY: default
default:
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
- $(MAKE) all; \
+ @if $(BYTECODE_ONLY); then : ; else \
+ $(SET_LD_PATH) $(MAKE) all; \
fi
+.PHONY: all
all: compile run
-PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so plugin_thread.so plugin4_unix.so a.so b.so c.so
+PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so \
+ mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so \
+ plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so \
+ plugin_thread.so plugin4_unix.so a.so b.so c.so
ADD_COMPFLAGS=-thread
-compile: $(PLUGINS) main mylib.so
+.PHONY: compile
+compile: $(PLUGINS) main$(EXE) mylib.so
+.PHONY: run
run:
@printf " ... testing 'main'"
- @./main plugin.so plugin2.so plugin_thread.so > result
- @$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1)
- @echo " => passed"
+ @./main$(EXE) plugin.so plugin2.so plugin_thread.so > result
+ @$(DIFF) reference result >/dev/null \
+ && echo " => passed" || echo " => failed"
-main: api.cmx main.cmx
- @$(OCAMLOPT) -thread -o main -linkall unix.cmxa threads.cmxa dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK)
+main$(EXE): api.cmx main.cmx
+ @$(OCAMLOPT) -thread -o main$(EXE) -linkall unix.cmxa threads.cmxa \
+ dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK)
-main_ext: api.cmx main.cmx factorial.$(O)
- @$(OCAMLOPT) -o main_ext dynlink.cmxa api.cmx main.cmx factorial.$(O)
+main_ext$(EXE): api.cmx main.cmx factorial.$(O)
+ @$(OCAMLOPT) -o main_ext$(EXE) dynlink.cmxa api.cmx main.cmx \
+ factorial.$(O)
sub/plugin3.cmx: sub/api.cmi sub/api.cmx sub/plugin3.ml
- @(cd sub; mv api.cmx api.cmx.bak; $(OCAMLOPT) -c $(COMPFLAGS) plugin3.ml; mv api.cmx.bak api.cmx)
+ @cd sub; \
+ mv api.cmx api.cmx.bak; \
+ $(OCAMLOPT) -c plugin3.ml; \
+ mv api.cmx.bak api.cmx
plugin2.cmx: api.cmx plugin.cmi plugin.cmx
- @(mv plugin.cmx plugin.cmx.bak; $(OCAMLOPT) -c $(COMPFLAGS) plugin2.ml; mv plugin.cmx.bak plugin.cmx)
+ @mv plugin.cmx plugin.cmx.bak;
+ @$(OCAMLOPT) -c plugin2.ml
+ @mv plugin.cmx.bak plugin.cmx
sub/api.so: sub/api.cmi sub/api.ml
- @(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) $(SHARED) api.ml)
+ @cd sub; $(OCAMLOPT) -c $(SHARED) api.ml
sub/api.cmi: sub/api.mli
- @(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) api.mli)
+ @cd sub; $(OCAMLOPT) -c api.mli
sub/api.cmx: sub/api.cmi sub/api.ml
- @(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) api.ml)
+ @cd sub; $(OCAMLOPT) -c api.ml
plugin.cmx: api.cmx plugin.cmi
sub/plugin.cmx: api.cmx
plugin4.cmx: api.cmx
main.cmx: api.cmx
plugin_ext.cmx: api.cmx plugin_ext.ml
- @$(OCAMLOPT) -c $(COMPFLAGS) plugin_ext.ml
+ @$(OCAMLOPT) -c plugin_ext.ml
plugin_ext.so: factorial.$(O) plugin_ext.cmx
- @$(OCAMLOPT) $(COMPFLAGS) -shared -o plugin_ext.so factorial.$(O) plugin_ext.cmx
+ @$(OCAMLOPT) -shared -o plugin_ext.so factorial.$(O) \
+ plugin_ext.cmx
plugin4_unix.so: plugin4.cmx
@$(OCAMLOPT) -shared -o plugin4_unix.so unix.cmxa plugin4.cmx
mylib.cmxa: plugin.cmx plugin2.cmx
@$(OCAMLOPT) $(COMPFLAGS) -a -o mylib.cmxa plugin.cmx plugin2.cmx
-factorial.$(O): factorial.c
- @$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" factorial.c
+factorial.$(O): factorial.c caml
+ @$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" -ccopt -I -ccopt . \
+ factorial.c
+
+caml:
+ @mkdir -p caml || :
+ @cp $(TOPDIR)/byterun/*.h caml/
+.PHONY: promote
promote:
@cp result reference
+.PHONY: clean
clean: defaultclean
@rm -f result *.so *.o *.cm* main main_ext *.exe *.s *.asm *.obj
@rm -f *.a *.lib
@rm -f sub/*.so sub/*.o sub/*.cm* sub/*.s sub/*.asm sub/*.obj
+ @rm -f marshal.data
+ @rm -rf caml
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let x = ref 0
let u = Random.int 1000
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let mods = ref []
let reg_mod name =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
print_endline "B is running";
incr A.x;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () = try raise (Invalid_argument "X") with Invalid_argument s ->
raise (Invalid_argument (s ^ s))
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
print_endline "C is running";
incr A.x;
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Alain Frisch, LexiFi */
+/* */
+/* Copyright 2007 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include "caml/mlvalues.h"
#include "caml/memory.h"
#include "caml/alloc.h"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
Api.add_cb (fun () -> print_endline "Callback from main")
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
print_endline Mypack.Packed1.mykey
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
Api.reg_mod "Packed1"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
Api.reg_mod "Packed1_client";
print_endline Packed1.mykey
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let rec f x = ignore ([x]); f x
let rec fact n = if n = 0 then 1 else n * fact (n - 1)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
val facts: int list
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(*external ex: int -> int = "caml_ex"*)
let () =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
Printf.printf "time = %f\n" (Unix.time ());
Api.reg_mod "Plugin"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
external fact: int -> string = "factorial"
let () =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let f x x x x x x x x x x x x x = ()
let g x = f x x x x x x x x
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let x = ref 0
let () =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let facts = [ (Random.int 4) ]
let () = print_endline "COUCOU"; print_char '\n'
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
Api.reg_mod "Plugin_thread";
let _t =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let f i =
Printf.printf "Sub/api: f called with %i\n" i;
i + 1
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
val f : int -> int
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let rec fact n = if n = 0 then 1 else n * fact (n - 1)
let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ]
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let () =
ignore (Api.f 10)
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+MAIN_MODULE=tformat
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
+ADD_MODULES=testing
+
+include ../../makefiles/Makefile.one
+include ../../makefiles/Makefile.common
--- /dev/null
+(*************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Pomdapi, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2011 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(*************************************************************************)
+
+(*
+
+A test file for the Format module.
+
+*)
+
+open Testing;;
+open Format;;
+
+let say s = Printf.printf s;;
+
+try
+
+ say "d/i positive\n%!";
+ test (sprintf "%d/%i" 42 43 = "42/43");
+ test (sprintf "%-4d/%-5i" 42 43 = "42 /43 ");
+ test (sprintf "%04d/%05i" 42 43 = "0042/00043");
+ test (sprintf "%+d/%+i" 42 43 = "+42/+43");
+ test (sprintf "% d/% i" 42 43 = " 42/ 43");
+ test (sprintf "%#d/%#i" 42 43 = "42/43");
+ test (sprintf "%4d/%5i" 42 43 = " 42/ 43");
+ test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43");
+ test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 ");
+
+ say "\nd/i negative\n%!";
+ test (sprintf "%d/%i" (-42) (-43) = "-42/-43");
+ test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43 ");
+ test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043");
+ test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43");
+ test (sprintf "% d/% i" (-42) (-43) = "-42/-43");
+ test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");
+ test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43");
+ test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43");
+ test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 ");
+
+ say "\nu positive\n%!";
+ test (sprintf "%u" 42 = "42");
+ test (sprintf "%-4u" 42 = "42 ");
+ test (sprintf "%04u" 42 = "0042");
+ test (sprintf "%+u" 42 = "42");
+ test (sprintf "% u" 42 = "42");
+ test (sprintf "%#u" 42 = "42");
+ test (sprintf "%4u" 42 = " 42");
+ test (sprintf "%*u" 4 42 = " 42");
+ test (sprintf "%-0+ #6d" 42 = "+42 ");
+
+ say "\nu negative\n%!";
+ begin match Sys.word_size with
+ | 32 ->
+ test (sprintf "%u" (-1) = "2147483647");
+ | 64 ->
+ test (sprintf "%u" (-1) = "9223372036854775807");
+ | _ -> test false
+ end;
+
+ say "\nx positive\n%!";
+ test (sprintf "%x" 42 = "2a");
+ test (sprintf "%-4x" 42 = "2a ");
+ test (sprintf "%04x" 42 = "002a");
+ test (sprintf "%+x" 42 = "2a");
+ test (sprintf "% x" 42 = "2a");
+ test (sprintf "%#x" 42 = "0x2a");
+ test (sprintf "%4x" 42 = " 2a");
+ test (sprintf "%*x" 5 42 = " 2a");
+ test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
+
+ say "\nx negative\n%!";
+ begin match Sys.word_size with
+ | 32 ->
+ test (sprintf "%x" (-42) = "7fffffd6");
+ | 64 ->
+ test (sprintf "%x" (-42) = "7fffffffffffffd6");
+ | _ -> test false
+ end;
+
+ say "\nX positive\n%!";
+ test (sprintf "%X" 42 = "2A");
+ test (sprintf "%-4X" 42 = "2A ");
+ test (sprintf "%04X" 42 = "002A");
+ test (sprintf "%+X" 42 = "2A");
+ test (sprintf "% X" 42 = "2A");
+ test (sprintf "%#X" 42 = "0X2A");
+ test (sprintf "%4X" 42 = " 2A");
+ test (sprintf "%*X" 5 42 = " 2A");
+ test (sprintf "%-0+ #*X" 5 42 = "0X2A ");
+
+ say "\nx negative\n%!";
+ begin match Sys.word_size with
+ | 32 ->
+ test (sprintf "%X" (-42) = "7FFFFFD6");
+ | 64 ->
+ test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6");
+ | _ -> test false
+ end;
+
+ say "\no positive\n%!";
+ test (sprintf "%o" 42 = "52");
+ test (sprintf "%-4o" 42 = "52 ");
+ test (sprintf "%04o" 42 = "0052");
+ test (sprintf "%+o" 42 = "52");
+ test (sprintf "% o" 42 = "52");
+ test (sprintf "%#o" 42 = "052");
+ test (sprintf "%4o" 42 = " 52");
+ test (sprintf "%*o" 5 42 = " 52");
+ test (sprintf "%-0+ #*o" 5 42 = "052 ");
+
+ say "\no negative\n%!";
+ begin match Sys.word_size with
+ | 32 ->
+ test (sprintf "%o" (-42) = "17777777726");
+ | 64 ->
+ test (sprintf "%o" (-42) = "777777777777777777726");
+ | _ -> test false
+ end;
+
+ say "\ns\n%!";
+ test (sprintf "%s" "foo" = "foo");
+ test (sprintf "%-5s" "foo" = "foo ");
+ test (sprintf "%05s" "foo" = " foo");
+ test (sprintf "%+s" "foo" = "foo");
+ test (sprintf "% s" "foo" = "foo");
+ test (sprintf "%#s" "foo" = "foo");
+ test (sprintf "%5s" "foo" = " foo");
+ test (sprintf "%1s" "foo" = "foo");
+ test (sprintf "%*s" 6 "foo" = " foo");
+ test (sprintf "%*s" 2 "foo" = "foo");
+ test (sprintf "%-0+ #5s" "foo" = "foo ");
+ test (sprintf "%s@@" "foo" = "foo@");
+ test (sprintf "%s@@inria.fr" "foo" = "foo@inria.fr");
+ test (sprintf "%s@@%s" "foo" "inria.fr" = "foo@inria.fr");
+
+ say "\nS\n%!";
+ test (sprintf "%S" "fo\"o" = "\"fo\\\"o\"");
+(* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *)
+(* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *)
+ test (sprintf "%+S" "foo" = "\"foo\"");
+ test (sprintf "% S" "foo" = "\"foo\"");
+ test (sprintf "%#S" "foo" = "\"foo\"");
+(* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *)
+ test (sprintf "%1S" "foo" = "\"foo\"");
+(* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *)
+ test (sprintf "%*S" 2 "foo" = "\"foo\"");
+(* test (sprintf "%-0+ #5S" "foo" = "\"foo\" "); padding not done *)
+ test (sprintf "%S@@" "foo" = "\"foo\"@");
+ test (sprintf "%S@@inria.fr" "foo" = "\"foo\"@inria.fr");
+ test (sprintf "%S@@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\"");
+
+ say "\nc\n%!";
+ test (sprintf "%c" 'c' = "c");
+(* test (sprintf "%-4c" 'c' = "c "); padding not done *)
+(* test (sprintf "%04c" 'c' = " c"); padding not done *)
+ test (sprintf "%+c" 'c' = "c");
+ test (sprintf "% c" 'c' = "c");
+ test (sprintf "%#c" 'c' = "c");
+(* test (sprintf "%4c" 'c' = " c"); padding not done *)
+(* test (sprintf "%*c" 2 'c' = " c"); padding not done *)
+(* test (sprintf "%-0+ #4c" 'c' = "c "); padding not done *)
+
+ say "\nC\n%!";
+ test (sprintf "%C" 'c' = "'c'");
+ test (sprintf "%C" '\'' = "'\\''");
+(* test (sprintf "%-4C" 'c' = "c "); padding not done *)
+(* test (sprintf "%04C" 'c' = " c"); padding not done *)
+ test (sprintf "%+C" 'c' = "'c'");
+ test (sprintf "% C" 'c' = "'c'");
+ test (sprintf "%#C" 'c' = "'c'");
+(* test (sprintf "%4C" 'c' = " c"); padding not done *)
+(* test (sprintf "%*C" 2 'c' = " c"); padding not done *)
+(* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *)
+
+ say "\nf\n%!";
+ test (sprintf "%f" (-42.42) = "-42.420000");
+ test (sprintf "%-13f" (-42.42) = "-42.420000 ");
+ test (sprintf "%013f" (-42.42) = "-00042.420000");
+ test (sprintf "%+f" 42.42 = "+42.420000");
+ test (sprintf "% f" 42.42 = " 42.420000");
+ test (sprintf "%#f" 42.42 = "42.420000");
+ test (sprintf "%13f" 42.42 = " 42.420000");
+ test (sprintf "%*f" 12 42.42 = " 42.420000");
+ test (sprintf "%-0+ #12f" 42.42 = "+42.420000 ");
+ test (sprintf "%.3f" (-42.42) = "-42.420");
+ test (sprintf "%-13.3f" (-42.42) = "-42.420 ");
+ test (sprintf "%013.3f" (-42.42) = "-00000042.420");
+ test (sprintf "%+.3f" 42.42 = "+42.420");
+ test (sprintf "% .3f" 42.42 = " 42.420");
+ test (sprintf "%#.3f" 42.42 = "42.420");
+ test (sprintf "%13.3f" 42.42 = " 42.420");
+ test (sprintf "%*.*f" 12 3 42.42 = " 42.420");
+ test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 ");
+
+ (* Under Windows (mingw and maybe also MSVC), the stdlib uses three
+ digits for the exponent instead of the two used by Linux and BSD.
+ Check that the two strings are equal, except that there may be an
+ extra zero, and if there is one, there may be a missing space or
+ zero. All in the first string relative to the second. *)
+ let ( =* ) s1 s2 =
+ let ss1 = s1 ^ "$" in
+ let ss2 = s2 ^ "$" in
+ let rec loop i1 i2 extra missing =
+ if i1 = String.length ss1 && i2 = String.length ss2 then begin
+ if extra then true else not missing
+ end else if i1 = String.length ss1 || i2 = String.length ss2 then
+ false
+ else begin
+ match ss1.[i1], ss2.[i2] with
+ | x, y when x = y -> loop (i1+1) (i2+1) extra missing
+ | '0', _ when not extra -> loop (i1+1) i2 true missing
+ | _, (' '|'0') when not missing -> loop i1 (i2+1) extra true
+ | _, _ -> false
+ end
+ in
+ loop 0 0 false false
+ in
+
+ say "\nF\n%!";
+ test (sprintf "%F" 42.42 = "42.42");
+ test (sprintf "%F" 42.42e42 =* "4.242e+43");
+ test (sprintf "%F" 42.00 = "42.");
+ test (sprintf "%F" 0.042 = "0.042");
+(* no padding, no precision
+ test (sprintf "%.3F" 42.42 = "42.420");
+ test (sprintf "%12.3F" 42.42e42 = " 4.242e+43");
+ test (sprintf "%.3F" 42.00 = "42.000");
+ test (sprintf "%.3F" 0.0042 = "0.004");
+*)
+
+ say "\ne\n%!";
+ test (sprintf "%e" (-42.42) =* "-4.242000e+01");
+ test (sprintf "%-15e" (-42.42) =* "-4.242000e+01 ");
+ test (sprintf "%015e" (-42.42) =* "-004.242000e+01");
+ test (sprintf "%+e" 42.42 =* "+4.242000e+01");
+ test (sprintf "% e" 42.42 =* " 4.242000e+01");
+ test (sprintf "%#e" 42.42 =* "4.242000e+01");
+ test (sprintf "%15e" 42.42 =* " 4.242000e+01");
+ test (sprintf "%*e" 14 42.42 =* " 4.242000e+01");
+ test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");
+ test (sprintf "%.3e" (-42.42) =* "-4.242e+01");
+ test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01 ");
+ test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01");
+ test (sprintf "%+.3e" 42.42 =* "+4.242e+01");
+ test (sprintf "% .3e" 42.42 =* " 4.242e+01");
+ test (sprintf "%#.3e" 42.42 =* "4.242e+01");
+ test (sprintf "%15.3e" 42.42 =* " 4.242e+01");
+ test (sprintf "%*.*e" 11 3 42.42 =* " 4.242e+01");
+ test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01 ");
+
+ say "\nE\n%!";
+ test (sprintf "%E" (-42.42) =* "-4.242000E+01");
+ test (sprintf "%-15E" (-42.42) =* "-4.242000E+01 ");
+ test (sprintf "%015E" (-42.42) =* "-004.242000E+01");
+ test (sprintf "%+E" 42.42 =* "+4.242000E+01");
+ test (sprintf "% E" 42.42 =* " 4.242000E+01");
+ test (sprintf "%#E" 42.42 =* "4.242000E+01");
+ test (sprintf "%15E" 42.42 =* " 4.242000E+01");
+ test (sprintf "%*E" 14 42.42 =* " 4.242000E+01");
+ test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");
+ test (sprintf "%.3E" (-42.42) =* "-4.242E+01");
+ test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01 ");
+ test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01");
+ test (sprintf "%+.3E" 42.42 =* "+4.242E+01");
+ test (sprintf "% .3E" 42.42 =* " 4.242E+01");
+ test (sprintf "%#.3E" 42.42 =* "4.242E+01");
+ test (sprintf "%15.3E" 42.42 =* " 4.242E+01");
+ test (sprintf "%*.*E" 11 3 42.42 =* " 4.242E+01");
+ test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 ");
+
+(* %g gives strange results that correspond to neither %f nor %e
+ say "\ng\n%!";
+ test (sprintf "%g" (-42.42) = "-42.42000");
+ test (sprintf "%-15g" (-42.42) = "-42.42000 ");
+ test (sprintf "%015g" (-42.42) = "-00000042.42000");
+ test (sprintf "%+g" 42.42 = "+42.42000");
+ test (sprintf "% g" 42.42 = " 42.42000");
+ test (sprintf "%#g" 42.42 = "42.42000");
+ test (sprintf "%15g" 42.42 = " 42.42000");
+ test (sprintf "%*g" 14 42.42 = " 42.42000");
+ test (sprintf "%-0+ #14g" 42.42 = "+42.42000 ");
+ test (sprintf "%.3g" (-42.42) = "-42.420");
+*)
+
+(* Same for %G
+ say "\nG\n%!";
+*)
+
+ say "\nB\n%!";
+ test (sprintf "%B" true = "true");
+ test (sprintf "%B" false = "false");
+
+ say "\nld/li positive\n%!";
+ test (sprintf "%ld/%li" 42l 43l = "42/43");
+ test (sprintf "%-4ld/%-5li" 42l 43l = "42 /43 ");
+ test (sprintf "%04ld/%05li" 42l 43l = "0042/00043");
+ test (sprintf "%+ld/%+li" 42l 43l = "+42/+43");
+ test (sprintf "% ld/% li" 42l 43l = " 42/ 43");
+ test (sprintf "%#ld/%#li" 42l 43l = "42/43");
+ test (sprintf "%4ld/%5li" 42l 43l = " 42/ 43");
+ test (sprintf "%*ld/%*li" 4 42l 5 43l = " 42/ 43");
+ test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 ");
+
+ say "\nld/li negative\n%!";
+ test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43");
+ test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43 ");
+ test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043");
+ test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43");
+ test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43");
+ test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");
+ test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/ -43");
+ test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/ -43");
+ test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 ");
+
+ say "\nlu positive\n%!";
+ test (sprintf "%lu" 42l = "42");
+ test (sprintf "%-4lu" 42l = "42 ");
+ test (sprintf "%04lu" 42l = "0042");
+ test (sprintf "%+lu" 42l = "42");
+ test (sprintf "% lu" 42l = "42");
+ test (sprintf "%#lu" 42l = "42");
+ test (sprintf "%4lu" 42l = " 42");
+ test (sprintf "%*lu" 4 42l = " 42");
+ test (sprintf "%-0+ #6ld" 42l = "+42 ");
+
+ say "\nlu negative\n%!";
+ test (sprintf "%lu" (-1l) = "4294967295");
+
+ say "\nlx positive\n%!";
+ test (sprintf "%lx" 42l = "2a");
+ test (sprintf "%-4lx" 42l = "2a ");
+ test (sprintf "%04lx" 42l = "002a");
+ test (sprintf "%+lx" 42l = "2a");
+ test (sprintf "% lx" 42l = "2a");
+ test (sprintf "%#lx" 42l = "0x2a");
+ test (sprintf "%4lx" 42l = " 2a");
+ test (sprintf "%*lx" 5 42l = " 2a");
+ test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");
+
+ say "\nlx negative\n%!";
+ test (sprintf "%lx" (-42l) = "ffffffd6");
+
+ say "\nlX positive\n%!";
+ test (sprintf "%lX" 42l = "2A");
+ test (sprintf "%-4lX" 42l = "2A ");
+ test (sprintf "%04lX" 42l = "002A");
+ test (sprintf "%+lX" 42l = "2A");
+ test (sprintf "% lX" 42l = "2A");
+ test (sprintf "%#lX" 42l = "0X2A");
+ test (sprintf "%4lX" 42l = " 2A");
+ test (sprintf "%*lX" 5 42l = " 2A");
+ test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");
+
+ say "\nlx negative\n%!";
+ test (sprintf "%lX" (-42l) = "FFFFFFD6");
+
+ say "\nlo positive\n%!";
+ test (sprintf "%lo" 42l = "52");
+ test (sprintf "%-4lo" 42l = "52 ");
+ test (sprintf "%04lo" 42l = "0052");
+ test (sprintf "%+lo" 42l = "52");
+ test (sprintf "% lo" 42l = "52");
+ test (sprintf "%#lo" 42l = "052");
+ test (sprintf "%4lo" 42l = " 52");
+ test (sprintf "%*lo" 5 42l = " 52");
+ test (sprintf "%-0+ #*lo" 5 42l = "052 ");
+
+ say "\nlo negative\n%!";
+ test (sprintf "%lo" (-42l) = "37777777726");
+
+ (* Nativeint not tested: looks like too much work, and anyway it should
+ work like Int32 or Int64. *)
+
+ say "\nLd/Li positive\n%!";
+ test (sprintf "%Ld/%Li" 42L 43L = "42/43");
+ test (sprintf "%-4Ld/%-5Li" 42L 43L = "42 /43 ");
+ test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043");
+ test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");
+ test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");
+ test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");
+ test (sprintf "%4Ld/%5Li" 42L 43L = " 42/ 43");
+ test (sprintf "%*Ld/%*Li" 4 42L 5 43L = " 42/ 43");
+ test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 ");
+
+ say "\nLd/Li negative\n%!";
+ test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43");
+ test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43 ");
+ test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043");
+ test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");
+ test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");
+ test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");
+ test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/ -43");
+ test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/ -43");
+ test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 ");
+
+ say "\nLu positive\n%!";
+ test (sprintf "%Lu" 42L = "42");
+ test (sprintf "%-4Lu" 42L = "42 ");
+ test (sprintf "%04Lu" 42L = "0042");
+ test (sprintf "%+Lu" 42L = "42");
+ test (sprintf "% Lu" 42L = "42");
+ test (sprintf "%#Lu" 42L = "42");
+ test (sprintf "%4Lu" 42L = " 42");
+ test (sprintf "%*Lu" 4 42L = " 42");
+ test (sprintf "%-0+ #6Ld" 42L = "+42 ");
+
+ say "\nLu negative\n%!";
+ test (sprintf "%Lu" (-1L) = "18446744073709551615");
+
+ say "\nLx positive\n%!";
+ test (sprintf "%Lx" 42L = "2a");
+ test (sprintf "%-4Lx" 42L = "2a ");
+ test (sprintf "%04Lx" 42L = "002a");
+ test (sprintf "%+Lx" 42L = "2a");
+ test (sprintf "% Lx" 42L = "2a");
+ test (sprintf "%#Lx" 42L = "0x2a");
+ test (sprintf "%4Lx" 42L = " 2a");
+ test (sprintf "%*Lx" 5 42L = " 2a");
+ test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");
+
+ say "\nLx negative\n%!";
+ test (sprintf "%Lx" (-42L) = "ffffffffffffffd6");
+
+ say "\nLX positive\n%!";
+ test (sprintf "%LX" 42L = "2A");
+ test (sprintf "%-4LX" 42L = "2A ");
+ test (sprintf "%04LX" 42L = "002A");
+ test (sprintf "%+LX" 42L = "2A");
+ test (sprintf "% LX" 42L = "2A");
+ test (sprintf "%#LX" 42L = "0X2A");
+ test (sprintf "%4LX" 42L = " 2A");
+ test (sprintf "%*LX" 5 42L = " 2A");
+ test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");
+
+ say "\nLx negative\n%!";
+ test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6");
+
+ say "\nLo positive\n%!";
+ test (sprintf "%Lo" 42L = "52");
+ test (sprintf "%-4Lo" 42L = "52 ");
+ test (sprintf "%04Lo" 42L = "0052");
+ test (sprintf "%+Lo" 42L = "52");
+ test (sprintf "% Lo" 42L = "52");
+ test (sprintf "%#Lo" 42L = "052");
+ test (sprintf "%4Lo" 42L = " 52");
+ test (sprintf "%*Lo" 5 42L = " 52");
+ test (sprintf "%-0+ #*Lo" 5 42L = "052 ");
+
+ say "\nLo negative\n%!";
+ test (sprintf "%Lo" (-42L) = "1777777777777777777726");
+
+ say "\na\n%!";
+ let x = ref () in
+ let f () y = if y == x then "ok" else "wrong" in
+ test (sprintf "%a" f x = "ok");
+
+ say "\nt\n%!";
+ let f () = "ok" in
+ test (sprintf "%t" f = "ok");
+
+(* %{ fmt %} prints the signature of [fmt], i.e. a canonical representation
+ of the conversions present in [fmt].
+*)
+ say "\n{...%%}\n%!";
+ let f = format_of_string "%f/%s" in
+ test (sprintf "%{%f%s%}" f = "%f%s");
+
+ say "\n(...%%)\n%!";
+ let f = format_of_string "%d/foo/%s" in
+ test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar");
+
+ say "\n! %% @ , and constants\n%!";
+ test (sprintf "%!" = "");
+ test (sprintf "%%" = "%");
+ test (sprintf "%@" = "@");
+ test (sprintf "%," = "");
+ test (sprintf "@@" = "@");
+ test (sprintf "@@@@" = "@@");
+ test (sprintf "@@%%" = "@%");
+
+ say "\nend of tests\n%!";
+with e ->
+ say "unexpected exception: %s\n%!" (Printexc.to_string e);
+ test false;
+;;
--- /dev/null
+d/i positive
+ 0 1 2 3 4 5 6 7 8
+d/i negative
+ 9 10 11 12 13 14 15 16 17
+u positive
+ 18 19 20 21 22 23 24 25 26
+u negative
+ 27
+x positive
+ 28 29 30 31 32 33 34 35 36
+x negative
+ 37
+X positive
+ 38 39 40 41 42 43 44 45 46
+x negative
+ 47
+o positive
+ 48 49 50 51 52 53 54 55 56
+o negative
+ 57
+s
+ 58 59 60 61 62 63 64 65 66 67 68 69 70 71
+S
+ 72 73 74 75 76 77 78 79 80
+c
+ 81 82 83 84
+C
+ 85 86 87 88 89
+f
+ 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
+F
+ 108 109 110 111
+e
+ 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
+E
+ 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
+B
+ 148 149
+ld/li positive
+ 150 151 152 153 154 155 156 157 158
+ld/li negative
+ 159 160 161 162 163 164 165 166 167
+lu positive
+ 168 169 170 171 172 173 174 175 176
+lu negative
+ 177
+lx positive
+ 178 179 180 181 182 183 184 185 186
+lx negative
+ 187
+lX positive
+ 188 189 190 191 192 193 194 195 196
+lx negative
+ 197
+lo positive
+ 198 199 200 201 202 203 204 205 206
+lo negative
+ 207
+Ld/Li positive
+ 208 209 210 211 212 213 214 215 216
+Ld/Li negative
+ 217 218 219 220 221 222 223 224 225
+Lu positive
+ 226 227 228 229 230 231 232 233 234
+Lu negative
+ 235
+Lx positive
+ 236 237 238 239 240 241 242 243 244
+Lx negative
+ 245
+LX positive
+ 246 247 248 249 250 251 252 253 254
+Lx negative
+ 255
+Lo positive
+ 256 257 258 259 260 261 262 263 264
+Lo negative
+ 265
+a
+ 266
+t
+ 267
+{...%}
+ 268
+(...%)
+ 269
+! % @ , and constants
+ 270 271 272 273 274 275 276
+end of tests
+
+All tests succeeded.
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2011 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Testing the hash function Hashtbl.hash *)
(* What is tested:
- reproducibility on various platforms, esp. 32/64 bit issues
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2011 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Hashtable operations, using maps as a reference *)
open Printf
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=intext
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test for output_value / input_value *)
let max_data_depth = 500000
test 606 (even' 142 = true);
test 607 (even' 142 = even 142)
+
+let test_mutual_rec_regression () =
+ (* this regression was reported by Cedric Pasteur in PR#5772 *)
+ let rec test_one q x = x > 3
+ and test_list q = List.for_all (test_one q) q in
+ let g () = () in
+ let f q = if test_list q then g () in
+
+ test 700 (try ignore (Marshal.to_string f [Marshal.Closures]); true
+ with _ -> false)
+
let main() =
if Array.length Sys.argv <= 2 then begin
test_out "intext.data"; test_in "intext.data";
test_block();
test_deep();
test_objects();
- test_infix ()
+ test_infix ();
+ test_mutual_rec_regression ();
end else
if Sys.argv.(1) = "make" then begin
let n = int_of_string Sys.argv.(2) in
Test 605 passed.
Test 606 passed.
Test 607 passed.
+Test 700 passed.
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2001 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/***********************************************************************/
+
#include <mlvalues.h>
#include <intext.h>
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
LIBRARIES=nums
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/num
+LD_PATH=$(TOPDIR)/otherlibs/num
PROGRAM_ARGS=1000
include $(BASEDIR)/makefiles/Makefile.several
+(*************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Estime, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2008 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(*************************************************************************)
+
(* Pi digits computed with the sreaming algorithm given on pages 4, 6
& 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
Gibbons, August 2004. *)
+(*************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Estime, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2008 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(*************************************************************************)
(* Pi digits computed with the sreaming algorithm given on pages 4, 6
& 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=test test_nats test_big_ints test_ratios test_nums test_io
MAIN_MODULE=end_test
-ADD_COMPFLAGS=-w a
LIBRARIES=nums
+ADD_COMPFLAGS=-w a -I $(OTOPDIR)/otherlibs/num
+LD_PATH=$(TOPDIR)/otherlibs/num
include $(BASEDIR)/makefiles/Makefile.one
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
Test.end_tests ();;
shift_right_towards_zero_big_int
1... 2...
extract_big_int
- 1... 2... 3... 4... 5... 6...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
hashing of big integers
1... 2... 3... 4... 5... 6...
create_ratio
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Printf;;
let flush_all () = flush stdout; flush stderr;;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Test;;
open Nat;;
open Big_int;;
(extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 0 32,
big_int_of_int64 2309737967L);;
test 6 eq_big_int
- (extract_big_int (big_int_of_int (-1)) 2048 254,
- zero_big_int);;
+ (extract_big_int (big_int_of_int (-1)) 0 16,
+ big_int_of_int 0xFFFF);;
+test 7 eq_big_int
+ (extract_big_int (big_int_of_int (-1)) 1027 12,
+ big_int_of_int 0xFFF);;
+test 8 eq_big_int
+ (extract_big_int (big_int_of_int (-1234567)) 0 16,
+ big_int_of_int 10617);;
+test 9 eq_big_int
+ (extract_big_int (minus_big_int (power_int_positive_int 2 64)) 64 20,
+ big_int_of_int 0xFFFFF);;
+test 10 eq_big_int
+ (extract_big_int (pred_big_int (minus_big_int (power_int_positive_int 2 64))) 64 20,
+ big_int_of_int 0xFFFFE);;
testing_function "hashing of big integers";;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Test
open Nat
open Big_int
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Test;;
open Nat;;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Test;;
open Nat;;
open Big_int;;
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Test;;
open Nat;;
open Big_int;;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
#MODULES=
MAIN_MODULE=tprintf
-ADD_COMPFLAGS=-I $(BASEDIR)/lib
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
ADD_MODULES=testing
include ../../makefiles/Makefile.one
(* *)
(*************************************************************************)
-(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *)
-
(*
A test file for the Printf module.
test (sprintf "%+C" 'c' = "'c'");
test (sprintf "% C" 'c' = "'c'");
test (sprintf "%#C" 'c' = "'c'");
-(* test (sprintf "%4C" 'c' = " c"); padding not done *)
-(* test (sprintf "%*C" 2 'c' = " c"); padding not done *)
-(* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *)
+(* test (sprintf "%4C" 'c' = " 'c'"); padding not done *)
+(* test (sprintf "%*C" 2 'c' = "'c'"); padding not done *)
+(* test (sprintf "%-0+ #4C" 'c' = "'c' "); padding not done *)
printf "\nf\n%!";
test (sprintf "%f" (-42.42) = "-42.420000");
test (sprintf "%*.*f" 12 3 42.42 = " 42.420");
test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 ");
+ (* Under Windows (mingw and maybe also MSVC), the stdlib uses three
+ digits for the exponent instead of the two used by Linux and BSD.
+ Check that the two strings are equal, except that there may be an
+ extra zero, and if there is one, there may be a missing space or
+ zero. All in the first string relative to the second. *)
+ let ( =* ) s1 s2 =
+ let ss1 = s1 ^ "$" in
+ let ss2 = s2 ^ "$" in
+ let rec loop i1 i2 extra missing =
+ if i1 = String.length ss1 && i2 = String.length ss2 then begin
+ if extra then true else not missing
+ end else if i1 = String.length ss1 || i2 = String.length ss2 then
+ false
+ else begin
+ match ss1.[i1], ss2.[i2] with
+ | x, y when x = y -> loop (i1+1) (i2+1) extra missing
+ | '0', _ when not extra -> loop (i1+1) i2 true missing
+ | _, (' '|'0') when not missing -> loop i1 (i2+1) extra true
+ | _, _ -> false
+ end
+ in
+ loop 0 0 false false
+ in
+
printf "\nF\n%!";
test (sprintf "%F" 42.42 = "42.42");
- test (sprintf "%F" 42.42e42 = "4.242e+43");
+ test (sprintf "%F" 42.42e42 =* "4.242e+43");
test (sprintf "%F" 42.00 = "42.");
test (sprintf "%F" 0.042 = "0.042");
(* no padding, no precision
*)
printf "\ne\n%!";
- test (sprintf "%e" (-42.42) = "-4.242000e+01");
- test (sprintf "%-15e" (-42.42) = "-4.242000e+01 ");
- test (sprintf "%015e" (-42.42) = "-004.242000e+01");
- test (sprintf "%+e" 42.42 = "+4.242000e+01");
- test (sprintf "% e" 42.42 = " 4.242000e+01");
- test (sprintf "%#e" 42.42 = "4.242000e+01");
- test (sprintf "%15e" 42.42 = " 4.242000e+01");
- test (sprintf "%*e" 14 42.42 = " 4.242000e+01");
- test (sprintf "%-0+ #14e" 42.42 = "+4.242000e+01 ");
- test (sprintf "%.3e" (-42.42) = "-4.242e+01");
- test (sprintf "%-15.3e" (-42.42) = "-4.242e+01 ");
- test (sprintf "%015.3e" (-42.42) = "-000004.242e+01");
- test (sprintf "%+.3e" 42.42 = "+4.242e+01");
- test (sprintf "% .3e" 42.42 = " 4.242e+01");
- test (sprintf "%#.3e" 42.42 = "4.242e+01");
- test (sprintf "%15.3e" 42.42 = " 4.242e+01");
- test (sprintf "%*.*e" 11 3 42.42 = " 4.242e+01");
- test (sprintf "%-0+ #14.3e" 42.42 = "+4.242e+01 ");
+ test (sprintf "%e" (-42.42) =* "-4.242000e+01");
+ test (sprintf "%-15e" (-42.42) =* "-4.242000e+01 ");
+ test (sprintf "%015e" (-42.42) =* "-004.242000e+01");
+ test (sprintf "%+e" 42.42 =* "+4.242000e+01");
+ test (sprintf "% e" 42.42 =* " 4.242000e+01");
+ test (sprintf "%#e" 42.42 =* "4.242000e+01");
+ test (sprintf "%15e" 42.42 =* " 4.242000e+01");
+ test (sprintf "%*e" 14 42.42 =* " 4.242000e+01");
+ test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");
+ test (sprintf "%.3e" (-42.42) =* "-4.242e+01");
+ test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01 ");
+ test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01");
+ test (sprintf "%+.3e" 42.42 =* "+4.242e+01");
+ test (sprintf "% .3e" 42.42 =* " 4.242e+01");
+ test (sprintf "%#.3e" 42.42 =* "4.242e+01");
+ test (sprintf "%15.3e" 42.42 =* " 4.242e+01");
+ test (sprintf "%*.*e" 11 3 42.42 =* " 4.242e+01");
+ test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01 ");
printf "\nE\n%!";
- test (sprintf "%E" (-42.42) = "-4.242000E+01");
- test (sprintf "%-15E" (-42.42) = "-4.242000E+01 ");
- test (sprintf "%015E" (-42.42) = "-004.242000E+01");
- test (sprintf "%+E" 42.42 = "+4.242000E+01");
- test (sprintf "% E" 42.42 = " 4.242000E+01");
- test (sprintf "%#E" 42.42 = "4.242000E+01");
- test (sprintf "%15E" 42.42 = " 4.242000E+01");
- test (sprintf "%*E" 14 42.42 = " 4.242000E+01");
- test (sprintf "%-0+ #14E" 42.42 = "+4.242000E+01 ");
- test (sprintf "%.3E" (-42.42) = "-4.242E+01");
- test (sprintf "%-15.3E" (-42.42) = "-4.242E+01 ");
- test (sprintf "%015.3E" (-42.42) = "-000004.242E+01");
- test (sprintf "%+.3E" 42.42 = "+4.242E+01");
- test (sprintf "% .3E" 42.42 = " 4.242E+01");
- test (sprintf "%#.3E" 42.42 = "4.242E+01");
- test (sprintf "%15.3E" 42.42 = " 4.242E+01");
- test (sprintf "%*.*E" 11 3 42.42 = " 4.242E+01");
- test (sprintf "%-0+ #14.3E" 42.42 = "+4.242E+01 ");
+ test (sprintf "%E" (-42.42) =* "-4.242000E+01");
+ test (sprintf "%-15E" (-42.42) =* "-4.242000E+01 ");
+ test (sprintf "%015E" (-42.42) =* "-004.242000E+01");
+ test (sprintf "%+E" 42.42 =* "+4.242000E+01");
+ test (sprintf "% E" 42.42 =* " 4.242000E+01");
+ test (sprintf "%#E" 42.42 =* "4.242000E+01");
+ test (sprintf "%15E" 42.42 =* " 4.242000E+01");
+ test (sprintf "%*E" 14 42.42 =* " 4.242000E+01");
+ test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");
+ test (sprintf "%.3E" (-42.42) =* "-4.242E+01");
+ test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01 ");
+ test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01");
+ test (sprintf "%+.3E" 42.42 =* "+4.242E+01");
+ test (sprintf "% .3E" 42.42 =* " 4.242E+01");
+ test (sprintf "%#.3E" 42.42 =* "4.242E+01");
+ test (sprintf "%15.3E" 42.42 =* " 4.242E+01");
+ test (sprintf "%*.*E" 11 3 42.42 =* " 4.242E+01");
+ test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 ");
(* %g gives strange results that correspond to neither %f nor %e
printf "\ng\n%!";
let f () = "ok" in
test (sprintf "%t" f = "ok");
-(* Does not work as expected. Should be fixed to work like %s.
+ (* Work as expected. Prints the format string type digest.
+ If you want to print the contents of the format string,
+ do not use a meta format; simply convert the format string
+ to a string and print it using %s. *)
+
printf "\n{...%%}\n%!";
- let f = format_of_string "%f/%s" in
- test (sprintf "%{%f%s%}" f = "%f/%s");
-*)
+ let f = format_of_string "%4g/%s" in
+ test (sprintf "%{%#0F%S%}" f = "%f%s");
printf "\n(...%%)\n%!";
let f = format_of_string "%d/foo/%s" in
266
t
267
-(...%)
+{...%}
268
+(...%)
+ 269
! % @ , and constants
- 269 270 271 272 273 274 275
+ 270 271 272 273 274 275 276
end of tests
All tests succeeded.
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+let () =
+ Random.self_init ();
+ let x = Random.int 10000 in
+ Random.self_init ();
+ let y = Random.int 1000 in
+ if x = y then print_endline "FAILED" else print_endline "PASSED"
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
-default: compile run
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+.PHONY: default
+default:
+ @$(SET_LD_PATH) $(MAKE) compile run
+.PHONY: compile
compile: tscanf2_io.cmo
+ @rm -f master.byte master.native master.native.exe
+ @rm -f slave.byte slave.native slave.native.exe
@$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml
@$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
+ @if $(BYTECODE_ONLY); then : ; else \
$(MAKE) tscanf2_io.cmx; \
- $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \
- $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \
+ $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native$(EXE) \
+ tscanf2_master.ml; \
+ $(OCAMLOPT) tscanf2_io.cmx -o slave.native$(EXE) tscanf2_slave.ml; \
fi
run:
@printf " ... testing with ocamlc"
- @./master.byte ./slave.byte > result.byte 2>&1
- @$(DIFF) reference result.byte > /dev/null || (echo " => failed" && exit 1)
- @if [ -z "$(BYTECODE_ONLY)" ]; then \
- printf " ocamlopt" && \
- ./master.native ./slave.native > result.native 2>&1 && \
- $(DIFF) reference result.native > /dev/null || (echo " => failed" && exit 1) \
- fi
- @echo " => passed"
+ @$(OCAMLRUN) ./master.byte "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+ `$(CYGPATH) ./slave.byte`" \
+ >result.byte 2>&1
+ @$(DIFF) reference result.byte >/dev/null \
+ && if $(BYTECODE_ONLY); then : ; else \
+ printf " ocamlopt"; \
+ ./master.native$(EXE) "`$(CYGPATH) ./slave.native`" \
+ >result.native 2>&1; \
+ $(DIFF) reference result.native >/dev/null; \
+ fi \
+ && echo " => passed" || echo " => failed"
+.PHONY: promote
promote:
@cp result.byte reference
+.PHONY: clean
clean: defaultclean
@rm -f master.* slave.* result.*
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2005 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* A very simple communication module using buffers. It should help detecting
advanced character reading by Scanf when using stdin. *)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2005 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* A very simple master:
- first launch a slave process,
- then repeat a random number of times:
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2005 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* A very simple slave:
- read the string " Ping" on stdin,
- then print the string "-pong" on stderr,
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=tscanf
-ADD_COMPFLAGS=-I $(BASEDIR)/lib
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
ADD_MODULES=testing
+TEST_TEMP_FILES=tscanf_data
include $(BASEDIR)/makefiles/Makefile.one
include $(BASEDIR)/makefiles/Makefile.common
(* *)
(*************************************************************************)
-(* $Id: tscanf.ml 12800 2012-07-30 18:59:07Z doligez $
+(*
A testbed file for the module Scanf.
let test_fmt fmt s = unit fmt s = s;;
-(* The following test9_string is a result for test9 scanning.
- Test9_string is the string "",
- that is character i tréma, followed by french right guillemet,
- followed by inverted question mark.
- It is NOT the string "Ôªø",
- that is uppercase o with circonflex accent, followed by commercial a,
- followed by empty set.
-
- In other words, the string "" has the following 3 characters
- "\239\187\191".
- It has NOT the characters "\212\170\248"!
-
- Beware with automatic translation by your own local settings
- (being your locale or your OS!)
-*)
-let test9_string = "";;
+let test9_string = "\239\187\191";;
let test_S = test_fmt "%S";;
let test9 () =
Scanf.bscanf ib "%S" id in
let res =
- sscanf "Une chaîne: \"celle-ci\" et \"celle-là\"!"
+ sscanf "Une chaine: \"celle-ci\" et \"celle-la\"!"
"%s %s %S %s %S %s"
(fun s1 s2 s3 s4 s5 s6 -> s1 ^ s2 ^ s3 ^ s4 ^ s5 ^ s6) in
- res = "Unechaîne:celle-cietcelle-là!" &&
+ res = "Unechaine:celle-cietcelle-la!" &&
(* Testing the result of reading a %S string. *)
unit "\"a\\\n b\"" = "ab" &&
unit "\"\\\n ab\"" = "ab" &&
(fun prenom nom poids ->
prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70)
&&
- sscanf "Jean-Luc\tde Léage\t68" "%[^\t] %[^\t] %d"
+ sscanf "Jean-Luc\tde Leage\t68" "%[^\t] %[^\t] %d"
(fun prenom nom poids ->
- prenom = "Jean-Luc" && nom = "de Léage" && poids = 68)
+ prenom = "Jean-Luc" && nom = "de Leage" && poids = 68)
&&
sscanf "Daniel\tde Rauglaudre\t66" "%s@\t %s@\t %d"
(fun prenom nom poids ->
failwith (Printf.sprintf "in file %s, unexpected end of file" fname)
;;
-(* Simpy test that the list of lines read from the file are the list of lines
+(* Simply test that the list of lines read from the file is the list of lines
written to it!. *)
let test54 () =
get_lines tscanf_data_file = tscanf_data_file_lines
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
-module M = Map.Make(struct type t = int let compare = compare end)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
let img x m = try Some(M.find x m) with Not_found -> None
-module S = Set.Make(struct type t = int let compare = compare end)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+module S = Set.Make(struct type t = int let compare (x:t) y = compare x y end)
let testvals = [0;1;2;3;4;5;6;7;8;9]
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
LIBRARIES=str
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str
+LD_PATH=$(TOPDIR)/otherlibs/str
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Printf
let build_result ngroups input =
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=testing
include $(BASEDIR)/makefiles/Makefile.several
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Gabriel Scherer, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let is_empty s =
try Stream.empty s; true with Stream.Failure -> false
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
LIBRARIES=unix threads
-ADD_COMPFLAGS=-thread
+ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
+ -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* POSIX threads and fork() *)
let compute_thread c = ignore c
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in
+ *' unix '*) exit 0;;
+ *) exit 3;;
+esac
+
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
LIBRARIES=unix threads
-ADD_COMPFLAGS=-thread
+ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
+ -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let main () =
let (rd, wr) = Unix.pipe() in
- let _ = Thread.create
+ let t = Thread.create
(fun () ->
- ignore (Unix.write wr "0123456789" 0 10);
- Thread.delay 3.0;
+ Thread.delay 1.0;
print_endline "closing fd...";
- Unix.close rd)
+ Unix.close wr;
+ )
() in
let buf = String.create 10 in
print_endline "reading...";
- ignore (Unix.read rd buf 0 10);
- print_endline "read returned"
+ begin try ignore (Unix.read rd buf 0 10) with Unix.Unix_error _ -> () end;
+ print_endline "read returned";
+ t
+
+let t = Unix.handle_unix_error main ()
-let _ = Unix.handle_unix_error main ()
+let _ = Thread.join t
reading...
+closing fd...
read returned
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Printf
open Thread
in Thread.create (integers 2) ch;
print_primes ch max;;
-let _ = go 1000
+let _ = go 500
;;
487
491
499
-503
-509
-521
-523
-541
-547
-557
-563
-569
-571
-577
-587
-593
-599
-601
-607
-613
-617
-619
-631
-641
-643
-647
-653
-659
-661
-673
-677
-683
-691
-701
-709
-719
-727
-733
-739
-743
-751
-757
-761
-769
-773
-787
-797
-809
-811
-821
-823
-827
-829
-839
-853
-857
-859
-863
-877
-881
-883
-887
-907
-911
-919
-929
-937
-941
-947
-953
-967
-971
-977
-983
-991
-997
--- /dev/null
+##
+# Host Database
+#
+# localhost is used to configure the loopback interface
+# when the system is booting. Do not change this entry.
+##
+127.0.0.1 localhost
+255.255.255.255 broadcasthost
+::1 localhost
+fe80::1%lo0 localhost
-LC_ALL=C sort test1.result | diff -q test1.reference -
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT test1.result | $DIFF test1.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Classic producer-consumer *)
type 'a prodcons =
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
sed -e 1q test2.result | grep -q '^[ab]*'
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let yield = ref false
let print_message c =
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
sed -e 1q test3.result | grep -q '^[ab]*'
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let print_message delay c =
while true do
print_char c; flush stdout; Thread.delay delay
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-./program > test3.result &
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program >test3.result &
pid=$!
sleep 5
kill -9 $pid
-LC_ALL=C sort -u test4.result | diff -q test4.reference -
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT -u test4.result | $DIFF test4.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let output_lock = Mutex.create()
let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2)
let fibtask n =
while true do
+ let res = fib n in
Mutex.lock output_lock;
- print_int(fib n); print_newline();
+ print_int res; print_newline();
Mutex.unlock output_lock
done
-./program < test4.data > test4.result 2> /dev/null || true
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program <test4.data >test4.result 2>/dev/null || true
-LC_ALL=C sort -u test5.result | diff -q test5.reference -
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT -u test5.result | $DIFF test5.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Event
let ch = (new_channel() : string channel)
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-./program > test5.result &
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program >test5.result &
pid=$!
sleep 3
kill -9 $pid
-LC_ALL=C sort -u test6.result | diff -q test6.reference -
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT -u test6.result | $DIFF test6.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Event
let ch = (new_channel() : string channel)
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-./program > test6.result &
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program >test6.result &
pid=$!
sleep 1
kill -9 $pid
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l`
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Event
let add_ch = new_channel()
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-./program > test7.result &
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program >test7.result &
pid=$!
sleep 1
kill -9 $pid
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Event
-type 'a buffer_channel = { input: 'a channel; output: 'a channel }
+type 'a buffer_channel = {
+ input: 'a channel;
+ output: 'a channel;
+ thread: Thread.t;
+}
let new_buffer_channel() =
let ic = new_channel() in
let oc = new_channel() in
- let buff = Queue.create() in
let rec buffer_process front rear =
match (front, rear) with
- ([], []) -> buffer_process [sync(receive ic)] []
+ | (["EOF"], []) -> Thread.exit ()
+ | ([], []) -> buffer_process [sync(receive ic)] []
| (hd::tl, _) ->
select [
wrap (receive ic) (fun x -> buffer_process front (x::rear));
wrap (send oc hd) (fun () -> buffer_process tl rear)
]
| ([], _) -> buffer_process (List.rev rear) [] in
- Thread.create (buffer_process []) [];
- { input = ic; output = oc }
+ let t = Thread.create (buffer_process []) [] in
+ { input = ic; output = oc; thread = t }
let buffer_send bc data =
sync(send bc.input data)
print_string (sync(buffer_receive box)); print_newline()
let _ =
- Thread.create f ();
- g()
+ let t = Thread.create f () in
+ g();
+ buffer_send box "EOF";
+ Thread.join box.thread;
+ Thread.join t
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT test9.result | $DIFF test9.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Event
type 'a swap_chan = ('a * 'a channel) channel
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-LC_ALL=C sort testA.result | diff -q testA.reference -
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT testA.result | $DIFF testA.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
let private_data_lock = Mutex.create()
let output_lock = Mutex.create()
-LC_ALL=C sort testexit.result | diff -q testexit.reference -
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+LC_ALL=C $SORT testexit.result | $DIFF testexit.reference -
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test Thread.exit *)
let somethread (name, limit, last) =
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test a file copy function *)
let test msg producer consumer src dst =
test "0...8192 byte chunks"
(copy_random 8192) (copy_random 8192) ifile ofile;
test "line per line, short lines"
- copy_line copy_line "/etc/hosts" ofile;
+ copy_line copy_line "test-file-short-lines" ofile;
let linesfile = Filename.temp_file "lines" "" in
make_lines linesfile;
test "line per line, short and long lines"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let sieve primes=
Event.sync (Event.send primes 0);
Event.sync (Event.send primes 1);
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
sed -e 1q testsignal.result | grep -q '^[ab]*Got ctrl-C, exiting...$'
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let sighandler _ =
print_string "Got ctrl-C, exiting..."; print_newline();
exit 0
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-./program > testsignal.result &
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program >testsignal.result &
pid=$!
sleep 3
kill -INT $pid
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
sed -e 1q testsignal2.result | grep -q '^[ab]*'
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let print_message delay c =
while true do
print_char c; flush stdout; Thread.delay delay
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$CANKILL
-./program > testsignal2.result &
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program >testsignal2.result &
pid=$!
sleep 3
kill -INT $pid
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Unix
let engine verbose number address =
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+
+##########################################
+##########################################
+#### TEMPORARY ####
+##########################################
+##########################################
+
+# disable this test on Windows non-cygwin ports until we decide
+# how to fix PR#5325 and PR#5578
+
+$CANKILL
\ No newline at end of file
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Performance test for mutexes and conditions *)
let mut = Mutex.create()
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Performance test for I/O scheduling *)
let mut = Mutex.create()
let token = ref 0
let process (n, ins, outs, nprocs) =
- let buf = String.create 1 in
- while true do
+ let buf = String.make 1 '.' in
+ while buf <> "-" do
Unix.read ins.(n) buf 0 1;
(* Printf.printf "Thread %d got the token\n" n; *)
if n = 0 then begin
decr niter;
- if !niter <= 0 then exit 0
+ if !niter <= 0 then buf.[0] <- '-';
end;
let next = if n + 1 >= nprocs then 0 else n + 1 in
(* Printf.printf "Thread %d sending token to thread %d\n" n next; *)
let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in
let ins = Array.create nprocs Unix.stdin in
let outs = Array.create nprocs Unix.stdout in
+ let threads = Array.create nprocs (Thread.self ()) in
for n = 0 to nprocs - 1 do
let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o
done;
niter := iter;
- for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done;
+ for i = 0 to nprocs - 1 do
+ threads.(i) <- Thread.create process (i, ins, outs, nprocs)
+ done;
Unix.write outs.(0) "X" 0 1;
- Thread.delay 3600.
+ for i = 0 to nprocs - 1 do Thread.join threads.(i) done
let _ = main()
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Torture test - lots of GC *)
+let finished = ref false;;
+
let gc_thread () =
- while true do
+ while not !finished do
(* print_string "gc"; print_newline(); *)
Gc.minor();
Thread.yield()
done
let stdin_thread () =
- while true do
+ while not !finished do
print_string ">"; flush stdout;
let s = read_line() in
print_string " >>> "; print_string s; print_newline()
done
let writer_thread (oc, size) =
- while true do
+ while not !finished do
(* print_string "writer "; print_int size; print_newline(); *)
let buff = String.make size 'a' in
Unix.write oc buff 0 size
- done
+ done;
+ let buff = String.make size 'b' in
+ Unix.write oc buff 0 size
let reader_thread (ic, size) =
while true do
let n = Unix.read ic buff 0 size in
(* print_string "reader "; print_int n; print_newline(); *)
for i = 0 to n-1 do
- if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
+ if buff.[i] = 'b' then raise Exit
+ else if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
done
done
let main() =
- Thread.create gc_thread ();
+ let t1 = Thread.create gc_thread () in
let (out1, in1) = Unix.pipe() in
- Thread.create writer_thread (in1, 4096);
- Thread.create reader_thread (out1, 4096);
+ let t2 = Thread.create writer_thread (in1, 4096) in
+ let t3 = Thread.create reader_thread (out1, 4096) in
let (out2, in2) = Unix.pipe() in
- Thread.create writer_thread (in2, 16);
- Thread.create reader_thread (out2, 16);
- stdin_thread()
+ let t4 = Thread.create writer_thread (in2, 16) in
+ let t5 = Thread.create reader_thread (out2, 16) in
+ try
+ stdin_thread()
+ with _ ->
+ finished := true;
+ List.iter Thread.join [t1; t2; t3; t4; t5]
let _ = main()
-./program < torture.data > torture.result 2> /dev/null || true
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$RUNTIME ./program <torture.data >torture.result 2>/dev/null || true
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=terms equations orderings kb
MAIN_MODULE=kbmain
(* *)
(***********************************************************************)
-(* $Id: equations.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(****************** Equation manipulations *************)
open Terms
(* *)
(***********************************************************************)
-(* $Id: equations.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Terms
type rule =
(* *)
(***********************************************************************)
-(* $Id: kb.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Terms
open Equations
(* *)
(***********************************************************************)
-(* $Id: kb.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Terms
open Equations
(* *)
(***********************************************************************)
-(* $Id: kbmain.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Terms
open Equations
open Orderings
(* *)
(***********************************************************************)
-(* $Id: orderings.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(*********************** Recursive Path Ordering ****************************)
open Terms
(* *)
(***********************************************************************)
-(* $Id: orderings.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Terms
type ordering =
(* *)
(***********************************************************************)
-(* $Id: terms.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(****************** Term manipulations *****************)
type term =
(* *)
(***********************************************************************)
-(* $Id: terms.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
type term =
Var of int
| Term of string * term list
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
UNSAFE=ON
include $(BASEDIR)/makefiles/Makefile.several
(* *)
(***********************************************************************)
-(* $Id: fft.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
let pi = 3.14159265358979323846
let tpi = 2.0 *. pi
(* *)
(***********************************************************************)
-(* $Id: quicksort.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Good test for loops. Best compiled with -unsafe. *)
let rec qsort lo hi (a : int array) =
(* *)
(***********************************************************************)
-(* $Id: soli.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-
type peg = Out | Empty | Peg
let board = [|
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
(* *)
(***********************************************************************)
-(* $Id: bdd.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Translated to OCaml by Xavier Leroy *)
(* Original code written in SML by ... *)
(* *)
(***********************************************************************)
-(* $Id: boyer.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Manipulations over terms *)
type term =
(* *)
(***********************************************************************)
-(* $Id: fib.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
let rec fib n =
if n < 2 then 1 else fib(n-1) + fib(n-2)
(* *)
(***********************************************************************)
-(* $Id: hamming.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* We cannot use bignums because we don't do custom runtimes, but
int64 is a bit short, so we roll our own 37-digit numbers...
*)
(* *)
(***********************************************************************)
-(* $Id: nucleic.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Use floating-point arithmetic *)
external (+) : float -> float -> float = "%addfloat"
(* *)
(***********************************************************************)
-(* $Id: sieve.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Eratosthene's sieve *)
(* interval min max = [min; min+1; ...; max-1; max] *)
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
(* Test bench for sorting algorithms. *)
let cmp = aux.prepf compare (<=) in
table3 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
;;
-\f
+
(************************************************************************)
(* merge sort on lists *)
in
mergeall_rev (init [] l)
;;
-\f
+
let lmerge_1b cmp l =
let rec init accu = function
| [] -> accu
in
mergeall_rev (init [] l)
;;
-\f
+
let lmerge_1c cmp l =
let rec init accu = function
| [] -> accu
in
mergeall_rev (init [] l)
;;
-\f
+
let lmerge_1d cmp l =
let rec init accu = function
| [] -> accu
in
mergeall_rev (init [] l)
;;
-\f
+
(************************************************************************)
(* merge sort on lists, user-contributed (NOT STABLE) *)
mergeall false (initlist l [])
(* END code contributed by Yann Coscoy *)
-\f
+
(************************************************************************)
(* merge sort on short lists, Francois Pottier *)
sort (List.length l) l
;;
(* END code contributed by Francois Pottier *)
-\f
+
(************************************************************************)
(* merge sort on short lists, Francois Pottier,
adapted to new-style interface *)
sort (List.length l) l
;;
(* END code contributed by Francois Pottier *)
-\f
+
(************************************************************************)
(* merge sort on short lists a la Pottier, modified merge *)
let len = List.length l in
if len < 2 then l else sort len l
;;
-\f
+
(************************************************************************)
(* merge sort on short lists a la Pottier, logarithmic stack space *)
if len < 2 then l else sort len l
;;
-\f
+
(************************************************************************)
(* merge sort on short lists a la Pottier, logarithmic stack space,
in place: input list is freed as the output is being computed. *)
let len = List.length l in
if len < 2 then l else sort len l
;;
-\f
+
(************************************************************************)
(* chop-free version of Pottier's code, binary version *)
while !len > 0 do incr i; len := !len lsr 1; done;
sort_prefix !i
;;
-\f
+
(************************************************************************)
(* chop-free version of Pottier's code, dichotomic version,
ground cases 1 & 2 *)
let len = List.length l in
if len <= 1 then l else sort_prefix len
;;
-\f
+
(************************************************************************)
(* chop-free version of Pottier's code, dichotomic version,
ground cases 2 & 3 *)
let len = List.length l in
if len <= 1 then l else sort_prefix len
;;
-\f
+
(************************************************************************)
(* chop-free, ref-free version of Pottier's code, dichotomic version,
ground cases 2 & 3, modified merge *)
let len = List.length l in
if len <= 1 then l else fst (sort_prefix len l)
;;
-\f
+
(************************************************************************)
(* merge sort on arrays, merge with tail-rec function *)
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let amerge_1b cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 3;;
let amerge_1c cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 4;;
let amerge_1d cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 5;;
let amerge_1e cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 6;;
let amerge_1f cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 7;;
let amerge_1g cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 8;;
let amerge_1h cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 9;;
let amerge_1i cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 10;;
let amerge_1j cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
(* FIXME a essayer: *)
(* list->array->list direct et array->list->array direct *)
(* overhead = 1/3, 1/4, etc. *)
(* overhead = sqrt (n) *)
(* overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *)
-\f
+
(************************************************************************)
(* merge sort on arrays, merge with loop *)
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let amerge_3b cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
let i1 = ref src1ofs
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 3;;
let amerge_3c cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 4;;
let amerge_3d cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 5;;
let amerge_3e cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 6;;
let amerge_3f cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 7;;
let amerge_3g cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 8;;
let amerge_3h cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 9;;
let amerge_3i cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
merge l2 l1 t 0 l2 a 0;
end;
;;
-\f
+
let cutoff = 10;;
let amerge_3j cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
;;
(* FIXME essayer bottom-up merge on arrays ? *)
-\f
+
(************************************************************************)
(* Shell sort on arrays *)
step := !step / 3;
done;
;;
-\f
+
let ashell_2 cmp a =
let l = Array.length a in
let step = ref 1 in
step := !step / 3;
done;
;;
-\f
+
let ashell_3 cmp a =
let l = Array.length a in
let step = ref 1 in
step := !step / 3;
done;
;;
-\f
+
let force = Lazy.force;;
type iilist = Cons of int * iilist Lazy.t;;
in
loop2 sc;
;;
-\f
+
(************************************************************************)
(* Quicksort on arrays *)
let cutoff = 1;;
done;
end;
;;
-\f
+
let cutoff = 2;;
let aquick_1b cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 3;;
let aquick_1c cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 4;;
let aquick_1d cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 5;;
let aquick_1e cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 6;;
let aquick_1f cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 7;;
let aquick_1g cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 1;;
let aquick_2a cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 2;;
let aquick_2b cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 3;;
let aquick_2c cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 4;;
let aquick_2d cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 5;;
let aquick_2e cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 6;;
let aquick_2f cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 7;;
let aquick_2g cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 1;;
let aquick_3a cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 2;;
let aquick_3b cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 3;;
let aquick_3c cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 4;;
let aquick_3d cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 5;;
let aquick_3e cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 6;;
let aquick_3f cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 7;;
let aquick_3g cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 8;;
let aquick_3h cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 9;;
let aquick_3i cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
let cutoff = 10;;
let aquick_3j cmp a =
let rec qsort l r = (* ASSUMES r - l >= 2 *)
done;
end;
;;
-\f
+
(************************************************************************)
(* Heap sort on arrays (top-down, ternary) *)
done;
if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end;
;;
-\f
+
(************************************************************************)
(* Heap sort on arrays (top-down, binary) *)
down i 0 e;
done;
;;
-\f
+
(************************************************************************)
(* Heap sort on arrays (bottom-up, ternary) *)
done;
if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
;;
-\f
+
(************************************************************************)
(* Heap sort on arrays (bottom-up, binary) *)
done;
if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
;;
-\f
+
(************************************************************************)
(* heap sort, top-down, ternary, recursive final loop *)
| 2 -> loop1 (l-1) l3;
| _ -> assert false;
;;
-\f
+
(************************************************************************)
(* heap sort, top-down, ternary, with exception *)
a.(j) <- e;
done;
;;
-\f
+
(************************************************************************)
(* merge sort on lists via arrays *)
in
loop 0 l
;;
-\f
+
(************************************************************************)
let lold = [
;;
if not !Sys.interactive then Printexc.catch main ();;
-
-(* $Id: sorts.ml 11123 2011-07-20 09:17:07Z doligez $ *)
(* *)
(***********************************************************************)
-(* $Id: takc.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
let rec tak x y z =
if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
else z
(* *)
(***********************************************************************)
-(* $Id: taku.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
let rec tak (x, y, z) =
if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
else z
-(* $Id: weaktest.ml 11123 2011-07-20 09:17:07Z doligez $ *)
+(*************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2008 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(*************************************************************************)
let debug = false;;
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Benedikt Meurer, os-cillation GmbH #
+# #
+# Copyright 1998 Institut National de Recherche en Informatique #
+# et en Automatique. Copyright 2013 Benedikt Meurer. All rights #
+# reserved. This file is distributed under the terms of the Q #
+# Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Benedikt Meurer, os-cillation GmbH *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique *)
+(* et en Automatique. Copyright 2013 Benedikt Meurer. All rights *)
+(* reserved. This file is distributed under the terms of the Q *)
+(* Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Printf
+
+external bswap16: int -> int = "%bswap16"
+external bswap32: int32 -> int32 = "%bswap_int32"
+external bswap64: int64 -> int64 = "%bswap_int64"
+
+let d16 = [0x11223344;
+ 0x0000f0f0]
+let d32 = [0x11223344l;
+ 0xf0f0f0f0l]
+let d64 = [0x1122334455667788L;
+ 0xf0f0f0f0f0f0f0f0L]
+
+let _ =
+ List.iter (fun x -> printf "%x\n" (bswap16 x)) d16;
+ List.iter (fun x -> printf "%lx\n" (bswap32 x)) d32;
+ List.iter (fun x -> printf "%Lx\n" (bswap64 x)) d64
--- /dev/null
+4433
+f0f0
+44332211
+f0f0f0f0
+8877665544332211
+f0f0f0f0f0f0f0f0
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, INRIA Saclay *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
let f x = x + x
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, INRIA Saclay *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
let f x = x + x
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
ADD_COMPFLAGS = -pp 'camlp4o'
MAIN_MODULE = camlp4_class_type_plus_ok
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2011 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
type t;;
type xdr_value;;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
MAIN_MODULE = pr5080_notes_ok
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2011 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let marshal_int f =
match [] with
| _ :: `INT n :: _ -> f n
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
MAIN_MODULE=pr5233
include ../../../makefiles/Makefile.one
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
open Printf;;
(* PR#5233: Create a dangling pointer and use it to access random parts
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
MAIN_MODULE=pr5757
include ../../../makefiles/Makefile.one
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
Random.init 3;;
for i = 0 to 100_000 do
ignore (String.create (Random.int 1_000_000))
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+MAIN_MODULE=pr6024
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2013 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+Format.printf "@[%@-@@-@]@.";;
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
+.PHONY: default
default: compile run
+.PHONY: compile
compile:
@for f in *.ml; do \
- $(OCAMLC) -w a -o `basename $$f ml`bytecode $$f; \
- test -z "$(BYTECODE_ONLY)" && $(OCAMLOPT) -w a -o `basename $$f ml`native $$f || true; \
+ F=`basename $$f .ml`; \
+ rm -f $$F.bytecode $$F.native $$F.native.exe; \
+ $(OCAMLC) -w a -o $$F.bytecode $$f; \
+ if $(BYTECODE_ONLY); then : ; else \
+ $(OCAMLOPT) -w a -o $$F.native$(EXE) $$f; \
+ fi; \
done
- @if [ ! `grep -c HAS_STACK_OVERFLOW_DETECTION ../../../config/s.h` ]; then \
- test -z "$(BYTECODE_ONLY)" && rm -f stackoverflow.byte stackoverflow.native || true; \
- fi
+ @grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/config/s.h \
+ || rm -f stackoverflow.native$(EXE)
+.PHONY: run
run:
@ulimit -s 1024; \
- for f in *.bytecode; do \
+ for f in *.bytecode; do \
printf " ... testing '$$f':"; \
- (./$$f > $$f.result 2>&1; true); \
- $(DIFF) $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
- if [ -z "$(BYTECODE_ONLY)" ]; then \
- printf " ... testing '`basename $$f bytecode`native':"; \
- (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \
- $(DIFF) `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
+ $(OCAMLRUN) ./$$f >$$f.result 2>&1 || true; \
+ DIFF="$(DIFF)" sh $$f.checker \
+ && echo " => passed" || echo " => failed"; \
+ fn=`basename $$f bytecode`native; \
+ if $(BYTECODE_ONLY) || [ ! -f "$${fn}$(EXE)" ] ; then : ; else \
+ printf " ... testing '$$fn':"; \
+ ./$${fn}$(EXE) >$$fn.result 2>&1 || true; \
+ DIFF="$(DIFF)" sh $$fn.checker \
+ && echo " => passed" || echo " => failed"; \
fi; \
done
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
- @rm -f *.bytecode *.native *.result
+ @rm -f *.bytecode *.native *.native.exe *.result
include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$DIFF stackoverflow.bytecode.reference stackoverflow.bytecode.result
+
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2001 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let rec f x =
if not (x = 0 || x = 10000 || x = 20000)
then 1 + f (x + 1)
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+$DIFF stackoverflow.native.reference stackoverflow.native.result
+
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+grep 'Fatal error: exception Sys_error' syserror.bytecode.result >/dev/null
+
+
+
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
let channel = open_out "titi:/toto"
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2013 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+grep 'Fatal error: exception Sys_error' syserror.native.result >/dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
MODULES=syntax gram_aux grammar scan_aux scanner lexgen output
MAIN_MODULE=main
(* *)
(***********************************************************************)
-(* $Id: gram_aux.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Auxiliaries for the parser. *)
open Syntax
/* */
/***********************************************************************/
-/* $Id: grammar.mly 12800 2012-07-30 18:59:07Z doligez $ */
-
/* The grammar for lexer definitions */
%{
(* *)
(***********************************************************************)
-(* $Id: input 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* The lexical analyzer for lexer definitions. *)
{
+++ /dev/null
-
-open Syntax
-open Grammar
-open Scan_aux
-
-let rec action_43 lexbuf = (
- comment lexbuf )
-and action_42 lexbuf = (
- raise(Lexical_error "unterminated comment") )
-and action_41 lexbuf = (
- reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- comment lexbuf )
-and action_40 lexbuf = (
- decr comment_depth;
- if !comment_depth = 0 then () else comment lexbuf )
-and action_39 lexbuf = (
- incr comment_depth; comment lexbuf )
-and action_38 lexbuf = (
- raise(Lexical_error "bad character constant") )
-and action_37 lexbuf = (
- char_for_decimal_code lexbuf 1 )
-and action_36 lexbuf = (
- char_for_backslash (Lexing.lexeme_char lexbuf 1) )
-and action_35 lexbuf = (
- Lexing.lexeme_char lexbuf 0 )
-and action_34 lexbuf = (
- store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf )
-and action_33 lexbuf = (
- raise(Lexical_error "unterminated string") )
-and action_32 lexbuf = (
- store_string_char(char_for_decimal_code lexbuf 1);
- string lexbuf )
-and action_31 lexbuf = (
- store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
- string lexbuf )
-and action_30 lexbuf = (
- string lexbuf )
-and action_29 lexbuf = (
- () )
-and action_28 lexbuf = (
- action lexbuf )
-and action_27 lexbuf = (
- raise (Lexical_error "unterminated action") )
-and action_26 lexbuf = (
- comment_depth := 1;
- comment lexbuf;
- action lexbuf )
-and action_25 lexbuf = (
- let _ = char lexbuf in action lexbuf )
-and action_24 lexbuf = (
- reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- action lexbuf )
-and action_23 lexbuf = (
- decr brace_depth;
- if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf )
-and action_22 lexbuf = (
- incr brace_depth;
- action lexbuf )
-and action_21 lexbuf = (
- raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) )
-and action_20 lexbuf = (
- raise(Lexical_error "unterminated lexer definition") )
-and action_19 lexbuf = (
- Tdash )
-and action_18 lexbuf = (
- Tcaret )
-and action_17 lexbuf = (
- Trparen )
-and action_16 lexbuf = (
- Tlparen )
-and action_15 lexbuf = (
- Tplus )
-and action_14 lexbuf = (
- Tmaybe )
-and action_13 lexbuf = (
- Tstar )
-and action_12 lexbuf = (
- Trbracket )
-and action_11 lexbuf = (
- Tlbracket )
-and action_10 lexbuf = (
- Teof )
-and action_9 lexbuf = (
- Tunderscore )
-and action_8 lexbuf = (
- Tor )
-and action_7 lexbuf = (
- Tend )
-and action_6 lexbuf = (
- Tequal )
-and action_5 lexbuf = (
- let n1 = Lexing.lexeme_end lexbuf in
- brace_depth := 1;
- let n2 = action lexbuf in
- Taction(Location(n1, n2)) )
-and action_4 lexbuf = (
- Tchar(char lexbuf) )
-and action_3 lexbuf = (
- reset_string_buffer();
- string lexbuf;
- Tstring(get_stored_string()) )
-and action_2 lexbuf = (
- match Lexing.lexeme lexbuf with
- "rule" -> Trule
- | "parse" -> Tparse
- | "and" -> Tand
- | "eof" -> Teof
- | s -> Tident s )
-and action_1 lexbuf = (
- comment_depth := 1;
- comment lexbuf;
- main lexbuf )
-and action_0 lexbuf = (
- main lexbuf )
-and state_0 lexbuf =
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A' -> state_51 lexbuf
- | ' '|'\013'|'\n'|'\t' -> state_40 lexbuf
- | '|' -> action_8 lexbuf
- | '{' -> action_5 lexbuf
- | 'e' -> state_56 lexbuf
- | '_' -> state_55 lexbuf
- | '^' -> action_18 lexbuf
- | ']' -> action_12 lexbuf
- | '[' -> action_11 lexbuf
- | '?' -> action_14 lexbuf
- | '=' -> action_6 lexbuf
- | ';' -> state_48 lexbuf
- | '-' -> action_19 lexbuf
- | '+' -> action_15 lexbuf
- | '*' -> action_13 lexbuf
- | ')' -> action_17 lexbuf
- | '(' -> state_43 lexbuf
- | '\'' -> action_4 lexbuf
- | '"' -> action_3 lexbuf
- | '\000' -> action_20 lexbuf
- | _ -> action_21 lexbuf
-and state_1 lexbuf =
- match lexing.next_char lexbuf with
- '}' -> action_23 lexbuf
- | '{' -> action_22 lexbuf
- | '(' -> state_34 lexbuf
- | '\'' -> action_25 lexbuf
- | '"' -> action_24 lexbuf
- | '\000' -> action_27 lexbuf
- | _ -> action_28 lexbuf
-and state_2 lexbuf =
- match lexing.next_char lexbuf with
- '\\' -> state_24 lexbuf
- | '"' -> action_29 lexbuf
- | '\000' -> action_33 lexbuf
- | _ -> action_34 lexbuf
-and state_3 lexbuf =
- match lexing.next_char lexbuf with
- '\\' -> state_13 lexbuf
- | '\000' -> lexing.backtrack lexbuf
- | _ -> state_12 lexbuf
-and state_4 lexbuf =
- match lexing.next_char lexbuf with
- '*' -> state_9 lexbuf
- | '(' -> state_8 lexbuf
- | '"' -> action_41 lexbuf
- | '\000' -> action_42 lexbuf
- | _ -> action_43 lexbuf
-and state_8 lexbuf =
- Lexing.set_backtrack lexbuf action_43;
- match lexing.next_char lexbuf with
- '*' -> action_39 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_9 lexbuf =
- Lexing.set_backtrack lexbuf action_43;
- match lexing.next_char lexbuf with
- ')' -> action_40 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_12 lexbuf =
- Lexing.set_backtrack lexbuf action_38;
- match lexing.next_char lexbuf with
- '\'' -> action_35 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_13 lexbuf =
- Lexing.set_backtrack lexbuf action_38;
- match lexing.next_char lexbuf with
- '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_15 lexbuf
- | 't'|'r'|'n'|'b'|'\\'|'\'' -> state_14 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_14 lexbuf =
- match lexing.next_char lexbuf with
- '\'' -> action_36 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_15 lexbuf =
- match lexing.next_char lexbuf with
- '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_16 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_16 lexbuf =
- match lexing.next_char lexbuf with
- '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_17 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_17 lexbuf =
- match lexing.next_char lexbuf with
- '\'' -> action_37 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_24 lexbuf =
- Lexing.set_backtrack lexbuf action_34;
- match lexing.next_char lexbuf with
- '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_27 lexbuf
- | 't'|'r'|'n'|'b'|'\\'|'"' -> action_31 lexbuf
- | ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_25 lexbuf =
- Lexing.set_backtrack lexbuf action_30;
- match lexing.next_char lexbuf with
- ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_27 lexbuf =
- match lexing.next_char lexbuf with
- '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_28 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_28 lexbuf =
- match lexing.next_char lexbuf with
- '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> action_32 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_34 lexbuf =
- Lexing.set_backtrack lexbuf action_28;
- match lexing.next_char lexbuf with
- '*' -> action_26 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_40 lexbuf =
- Lexing.set_backtrack lexbuf action_0;
- match lexing.next_char lexbuf with
- ' '|'\013'|'\n'|'\t' -> state_65 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_43 lexbuf =
- Lexing.set_backtrack lexbuf action_16;
- match lexing.next_char lexbuf with
- '*' -> action_1 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_48 lexbuf =
- Lexing.set_backtrack lexbuf action_21;
- match lexing.next_char lexbuf with
- ';' -> action_7 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_51 lexbuf =
- Lexing.set_backtrack lexbuf action_2;
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | '_' -> state_60 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_55 lexbuf =
- Lexing.set_backtrack lexbuf action_9;
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_56 lexbuf =
- Lexing.set_backtrack lexbuf action_2;
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | 'o' -> state_61 lexbuf
- | '_' -> state_60 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_59 lexbuf =
- Lexing.set_backtrack lexbuf action_2;
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | '_' -> state_60 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_60 lexbuf =
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_61 lexbuf =
- Lexing.set_backtrack lexbuf action_2;
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | 'f' -> state_62 lexbuf
- | '_' -> state_60 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_62 lexbuf =
- Lexing.set_backtrack lexbuf action_2;
- match lexing.next_char lexbuf with
- 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- | '_' -> state_60 lexbuf
- | _ -> lexing.backtrack lexbuf
-and state_65 lexbuf =
- Lexing.set_backtrack lexbuf action_0;
- match lexing.next_char lexbuf with
- ' '|'\013'|'\n'|'\t' -> state_65 lexbuf
- | _ -> lexing.backtrack lexbuf
-and main lexbuf =
- Lexing.init lexbuf;
- state_0 lexbuf
-
-and action lexbuf =
- Lexing.init lexbuf;
- state_1 lexbuf
-
-and string lexbuf =
- Lexing.init lexbuf;
- state_2 lexbuf
-
-and char lexbuf =
- Lexing.init lexbuf;
- state_3 lexbuf
-
-and comment lexbuf =
- Lexing.init lexbuf;
- state_4 lexbuf
(* *)
(***********************************************************************)
-(* $Id: lexgen.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Compiling a lexer definition *)
open Syntax
(* *)
(***********************************************************************)
-(* $Id: main.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The lexer generator. Command-line parsing. *)
open Syntax
(* *)
(***********************************************************************)
-(* $Id: output.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Generating a DFA as a set of mutually recursive functions *)
open Syntax
(* *)
(***********************************************************************)
-(* $Id: scan_aux.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Auxiliaries for the lexical analyzer *)
let brace_depth = ref 0
(* *)
(***********************************************************************)
-(* $Id: scanner.mll 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* The lexical analyzer for lexer definitions. *)
{
(* *)
(***********************************************************************)
-(* $Id: syntax.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The shallow abstract syntax *)
type location =
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
SHOULD_FAIL=t060-raise.ml
@for file in t*.ml; do \
printf " ... testing '$$file'"; \
if [ `echo $(SHOULD_FAIL) | grep $$file` ]; then \
- $(OCAML) -w a lib.cmo $$file 2> /dev/null && (echo " => failed" && exit 1) || echo " => passed"; \
+ $(OCAML) -w a lib.cmo $$file 2>/dev/null \
+ && echo " => failed" || echo " => passed"; \
else \
- $(OCAML) -w a lib.cmo $$file 2> /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+ $(OCAML) -w a lib.cmo $$file 2>/dev/null \
+ && echo " => passed" || echo " => failed"; \
fi; \
done
-(* file $Id: lib.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
external raise : exn -> 'a = "%raise"
external not : bool -> bool = "%boolnot"
external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";;
let x = 42;;
-
-(* eof $Id: lib.ml 11123 2011-07-20 09:17:07Z doligez $ *)
t301-object.ml -o t301-object.byte
***)
-(* $Id: t301-object.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
class c = object (self)
method pubmet = 1
if x <> 1 then raise Not_found;
if y <> 2 then raise Not_found;
if z <> 4 then raise Not_found;;
-
-(**** eof $Id: t301-object.ml 12800 2012-07-30 18:59:07Z doligez $ *)
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
CUSTOM_MODULE=odoc_test
-ADD_COMPFLAGS=-I +ocamldoc
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
-DIFF_OPT=--strip-trailing-cr
-#DIFF_OPT=-b
+.PHONY: default
+default:
+ @$(SET_LD_PATH) $(MAKE) run
+.PHONY: run
run: $(CUSTOM_MODULE).cmo
@for file in t*.ml; do \
printf " ... testing '$$file'"; \
- $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \
- $(DIFF) $(DIFF_OPT) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+ F="`basename $$file .ml`"; \
+ $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -g $(CUSTOM_MODULE).cmo \
+ -o $$F.result $$file; \
+ $(DIFF) $$F.reference $$F.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
done;
- @$(OCAMLDOC) -hide-warnings -html t*.ml 2>&1 | grep -v test_types_display || true
- @$(OCAMLDOC) -hide-warnings -latex t*.ml 2>&1 | grep -v test_types_display || true
+ @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -html t*.ml 2>&1 \
+ | grep -v test_types_display || true
+ @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex t*.ml 2>&1 \
+ | grep -v test_types_display || true
+.PHONY: promote
promote: defaultpromote
+.PHONY: clean
clean: defaultclean
@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
(***********************************************************************)
+(* *)
(* OCamldoc *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(***********************************************************************)
-(* $Id: odoc_test.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(** Custom generator to perform test on ocamldoc. *)
open Odoc_info
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
#MODULES=
MAIN_MODULE=fstclassmod
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
^^^^^^^^^^^^^^^^^
Error: This pattern matches values of type a * a vlist
but a pattern was expected which matches values of type
- ex#46 = ex#47 * ex#48
+ a#5 = ex#34 * ex#35
+ Type a is not compatible with type ex#34
# type (_, _) ty =
Int : (int, 'd) ty
| String : (string, 'f) ty
^^^^^^^^^^^^^^^^^
Error: This pattern matches values of type a * a vlist
but a pattern was expected which matches values of type
- ex#46 = ex#47 * ex#48
+ a#5 = ex#34 * ex#35
+ Type a is not compatible with type ex#34
# type (_, _) ty =
Int : (int, 'd) ty
| String : (string, 'f) ty
type ('a,'b) sum = Inl of 'a | Inr of 'b
type zero = Zero
-type _ succ
+type 'a succ = Succ of 'a
type _ nat =
| NZ : zero nat
| NS : 'a nat -> 'a succ nat
(* We do not have kinds, but we can encode them as predicates *)
-type tp
-type nd
-type (_,_) fk
+type tp = TP
+type nd = ND
+type ('a,'b) fk = FK
type _ shape =
| Tp : tp shape
| Nd : nd shape
| Fk : 'a shape * 'b shape -> ('a,'b) fk shape
;;
-type tt
-type ff
+type tt = TT
+type ff = FF
type _ boolean =
| BT : tt boolean
| BF : ff boolean
| _ -> None
;;
+(* Extra: associativity of addition *)
+
+let rec plus_func : type a b m n.
+ (a,b,m) plus -> (a,b,n) plus -> (m,n) equal =
+ fun p1 p2 ->
+ match p1, p2 with
+ | PlusZ _, PlusZ _ -> Eq
+ | PlusS p1', PlusS p2' ->
+ let Eq = plus_func p1' p2' in Eq
+
+let rec plus_assoc : type a b c ab bc m n.
+ (a,b,ab) plus -> (ab,c,m) plus ->
+ (b,c,bc) plus -> (a,bc,n) plus -> (m,n) equal = fun p1 p2 p3 p4 ->
+ match p1, p4 with
+ | PlusZ b, PlusZ bc ->
+ let Eq = plus_func p2 p3 in Eq
+ | PlusS p1', PlusS p4' ->
+ let PlusS p2' = p2 in
+ let Eq = plus_assoc p1' p2' p3 p4' in Eq
+;;
+
(* 3.9 Computing Programs and Properties Simultaneously *)
(* Plus and app1 are moved to section 2 *)
(* Exercise 22: Red-black trees *)
-type red
-type black
+type red = RED
+type black = BLACK
type (_,_) sub_tree =
| Bleaf : (black, zero) sub_tree
| Rnode :
(* 5.9/5.10 Language with binding *)
-type rnil
-type (_,_,_) rcons
+type rnil = RNIL
+type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
type _ is_row =
| Rnil : rnil is_row
(* 5.12 Soundness *)
-type pexp
-type pval
+type pexp = PEXP
+type pval = PVAL
type _ mode =
| Pexp : pexp mode
| Pval : pval mode
-type (_,_) tarr
-type tint
+type ('a,'b) tarr = TARR
+type tint = TINT
type (_,_) rel =
| IntR : (tint, int) rel
# * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b
type zero = Zero
-type _ succ
+type 'a succ = Succ of 'a
type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
# type (_, _) seq =
Snil : ('a, zero) seq
# * type (_, _, _) app =
App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
-# * type tp
-type nd
-type (_, _) fk
+# * type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
type _ shape =
Tp : tp shape
| Nd : nd shape
| Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-# type tt
-type ff
+# type tt = TT
+type ff = FF
type _ boolean = BT : tt boolean | BF : ff boolean
# type (_, _) path =
Pnone : 'a -> (tp, 'a) path
# type (_, _) equal = Eq : ('a, 'a) equal
val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
+# val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+ <fun>
+val plus_assoc :
+ ('a, 'b, 'ab) plus ->
+ ('ab, 'c, 'm) plus ->
+ ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = <fun>
# val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
# type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
# * * * * * * * * * val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
| Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
val del : int -> 'n avl -> 'n avl_del = <fun>
# val delete : int -> avl' -> avl' = <fun>
-# type red
-type black
+# type red = RED
+type black = BLACK
type (_, _) sub_tree =
Bleaf : (black, zero) sub_tree
| Rnode : (black, 'n) sub_tree * int *
Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
Const 3)
val v4 : int = 6
-# type rnil
-type (_, _, _) rcons
+# type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
type _ is_row =
Rnil : rnil is_row
| Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
I)
# val eval_checked : 'a env -> 'a checked -> int = <fun>
# val v2 : int = 6
-# type pexp
-type pval
+# type pexp = PEXP
+type pval = PVAL
type _ mode = Pexp : pexp mode | Pval : pval mode
-type (_, _) tarr
-type tint
+type ('a, 'b) tarr = TARR
+type tint = TINT
type (_, _) rel =
IntR : (tint, int) rel
| IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
# * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b
type zero = Zero
-type _ succ
+type 'a succ = Succ of 'a
type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
# type (_, _) seq =
Snil : ('a, zero) seq
# * type (_, _, _) app =
App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
-# * type tp
-type nd
-type (_, _) fk
+# * type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
type _ shape =
Tp : tp shape
| Nd : nd shape
| Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-# type tt
-type ff
+# type tt = TT
+type ff = FF
type _ boolean = BT : tt boolean | BF : ff boolean
# type (_, _) path =
Pnone : 'a -> (tp, 'a) path
# type (_, _) equal = Eq : ('a, 'a) equal
val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
+# val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+ <fun>
+val plus_assoc :
+ ('a, 'b, 'ab) plus ->
+ ('ab, 'c, 'm) plus ->
+ ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = <fun>
# val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
# type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
# * * * * * * * * * val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
| Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
val del : int -> 'n avl -> 'n avl_del = <fun>
# val delete : int -> avl' -> avl' = <fun>
-# type red
-type black
+# type red = RED
+type black = BLACK
type (_, _) sub_tree =
Bleaf : (black, zero) sub_tree
| Rnode : (black, 'n) sub_tree * int *
Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
Const 3)
val v4 : int = 6
-# type rnil
-type (_, _, _) rcons
+# type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
type _ is_row =
Rnil : rnil is_row
| Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
I)
# val eval_checked : 'a env -> 'a checked -> int = <fun>
# val v2 : int = 6
-# type pexp
-type pval
+# type pexp = PEXP
+type pval = PVAL
type _ mode = Pexp : pexp mode | Pval : pval mode
-type (_, _) tarr
-type tint
+type ('a, 'b) tarr = TARR
+type tint = TINT
type (_, _) rel =
IntR : (tint, int) rel
| IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
# type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-# Characters 272-279:
- | (Kind Maylink, Ast_Link lnk) -> Link lnk
- ^^^^^^^
-Error: This pattern matches values of type inkind linkp
- but a pattern was expected which matches values of type
- ([< inkind ] as 'a) linkp
- Type inkind = [ `Link | `Nonlink ] is not compatible with type
- 'a = [< `Link | `Nonlink ]
+# Characters 184-192:
+ | (Kind _, Ast_Text txt) -> Text txt
+ ^^^^^^^^
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+ but an expression was expected of type a inline_t
+ Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+ a = [< `Link | `Nonlink ]
Types for tag `Nonlink are incompatible
#
# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
# type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-# Characters 272-279:
- | (Kind Maylink, Ast_Link lnk) -> Link lnk
- ^^^^^^^
-Error: This pattern matches values of type inkind linkp
- but a pattern was expected which matches values of type
- ([< inkind ] as 'a) linkp
- Type inkind = [ `Link | `Nonlink ] is not compatible with type
- 'a = [< `Link | `Nonlink ]
+# Characters 184-192:
+ | (Kind _, Ast_Text txt) -> Text txt
+ ^^^^^^^^
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+ but an expression was expected of type a inline_t
+ Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+ a = [< `Link | `Nonlink ]
Types for tag `Nonlink are incompatible
#
--- /dev/null
+module Add (T : sig type two end) =
+struct
+ type _ t =
+ | One : [`One] t
+ | Two : T.two t
+
+ let add (type a) : a t * a t -> string = function
+ | One, One -> "two"
+ | Two, Two -> "four"
+end;;
--- /dev/null
+
+# Characters 137-194:
+ ...........................................function
+ | One, One -> "two"
+ | Two, Two -> "four"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Two, One)
+module Add :
+ functor (T : sig type two end) ->
+ sig
+ type _ t = One : [ `One ] t | Two : T.two t
+ val add : 'a t * 'a t -> string
+ end
+#
--- /dev/null
+module B : sig
+ type (_, _) t = Eq: ('a, 'a) t
+ val f: 'a -> 'b -> ('a, 'b) t
+end
+=
+struct
+ type (_, _) t = Eq: ('a, 'a) t
+ let f t1 t2 = Obj.magic Eq
+end;;
+
+let of_type: type a. a -> a = fun x ->
+ match B.f x 4 with
+ | Eq -> 5
+;;
--- /dev/null
+
+# module B :
+ sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
+# Characters 65-67:
+ | Eq -> 5
+ ^^
+Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
+#
--- /dev/null
+type _ constant =
+ | Int: int -> int constant
+ | Bool: bool -> bool constant
+
+type (_, _, _) binop =
+ | Eq: ('a, 'a, bool) binop
+ | Leq: ('a, 'a, bool) binop
+ | Add: (int, int, int) binop
+
+let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant) (y:b constant) : c constant =
+ match bop, x, y with
+ | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+ | Leq, Int x, Int y -> Bool (x <= y)
+ | Leq, Bool x, Bool y -> Bool (x <= y)
+ | Add, Int x, Int y -> Int (x + y)
+
+let _ = eval Eq (Int 2) (Int 3)
--- /dev/null
+
+#
+Characters 524-524:
+ Error: Syntax error
+#
--- /dev/null
+type tag = [`TagA | `TagB | `TagC];;
+
+type 'a poly =
+ AandBTags : [< `TagA of int | `TagB ] poly
+ | ATag : [< `TagA of int] poly
+(* constraint 'a = [< `TagA of int | `TagB] *)
+;;
+
+let intA = function `TagA i -> i
+let intB = function `TagB -> 4
+;;
+
+let intAorB = function
+ `TagA i -> i
+ | `TagB -> 4
+;;
+
+type _ wrapPoly =
+ WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly
+;;
+
+let example6 : type a. a wrapPoly -> (a -> int) =
+ fun w ->
+ match w with
+ | WrapPoly ATag -> intA
+ | WrapPoly _ -> intA (* This should not be allowed *)
+;;
+
+let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+;;
--- /dev/null
+
+# type tag = [ `TagA | `TagB | `TagC ]
+# type 'a poly =
+ AandBTags : [< `TagA of int | `TagB ] poly
+ | ATag : [< `TagA of int ] poly
+# val intA : [< `TagA of 'a ] -> 'a = <fun>
+val intB : [< `TagB ] -> int = <fun>
+# val intAorB : [< `TagA of int | `TagB ] -> int = <fun>
+# type _ wrapPoly =
+ WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
+# Characters 103-107:
+ | WrapPoly ATag -> intA
+ ^^^^
+Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
+ but an expression was expected of type a -> int
+ Type 'a is not compatible with type a = [< `TagA of int | `TagB ]
+ The first variant type does not allow tag(s) `TagB
+# Characters 10-18:
+ let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+ ^^^^^^^^
+Error: Unbound value example6
+#
--- /dev/null
+module F(S : sig type 'a t end) = struct
+ type _ ab =
+ A : int S.t ab
+ | B : float S.t ab
+
+ let f : int S.t ab -> float S.t ab -> string =
+ fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
+ | A, B -> "f A B"
+end;;
+
+module F(S : sig type 'a t end) = struct
+ type a = int * int
+ type b = int -> int
+
+ type _ ab =
+ A : a S.t ab
+ | B : b S.t ab
+
+ let f : a S.t ab -> b S.t ab -> string =
+ fun l r -> match l, r with
+ | A, B -> "f A B"
+end;;
--- /dev/null
+
+# Characters 196-233:
+ ...............................................match l, r with
+ | A, B -> "f A B"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(A, A)
+module F :
+ functor (S : sig type 'a t end) ->
+ sig
+ type _ ab = A : int S.t ab | B : float S.t ab
+ val f : int S.t ab -> float S.t ab -> string
+ end
+# Characters 197-234:
+ ...............match l, r with
+ | A, B -> "f A B"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(A, A)
+module F :
+ functor (S : sig type 'a t end) ->
+ sig
+ type a = int * int
+ type b = int -> int
+ type _ ab = A : a S.t ab | B : b S.t ab
+ val f : a S.t ab -> b S.t ab -> string
+ end
+#
--- /dev/null
+(* Report from Jeremy Yallop *)
+module F (S : sig type 'a s end) = struct
+ include S
+ type _ t = T : 'a -> 'a s t
+end;; (* fail *)
+(*
+module M = F (struct type 'a s = int end) ;;
+let M.T x = M.T 3 in x = true;;
+*)
+
+(* Fix it using #-annotations *)
+module F (S : sig type #'a s end) = struct
+ include S
+ type _ t = T : 'a -> 'a s t
+end;; (* syntax error *)
+(*
+module M = F (struct type 'a s = int end) ;; (* fail *)
+module M = F (struct type 'a s = new int end) ;; (* ok *)
+let M.T x = M.T 3 in x = true;; (* fail *)
+let M.T x = M.T 3 in x = 3;; (* ok *)
+*)
+
+(* Another version using OCaml 2.00 objects *)
+module F(T:sig type 'a t end) = struct
+ class ['a] c x =
+ object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
+end;; (* fail *)
+
+(* It is not OK to allow modules exported by other compilation units *)
+type (_,_) eq = Eq : ('a,'a) eq;;
+let eq = Obj.magic Eq;;
+(* pretend that Queue.t is not injective *)
+let eq : ('a Queue.t, 'b Queue.t) eq = eq;;
+type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+(*
+let castT (type a) (type b) (x : a t) (e: (a, b) eq) : b t =
+ let Eq = e in (x : b t);;
+let T (x : bool) = castT (T 3) eq;; (* we found a contradiction *)
+*)
+
+(* The following signature should not be accepted *)
+module type S = sig
+ type 'a s
+ type _ t = T : 'a -> 'a s t
+end;; (* fail *)
+(* Otherwise we can write the following *)
+module rec M : (S with type 'a s = unit) = M;;
+(* For the above reason, we cannot allow the abstract declaration
+ of s and the definition of t to be in the same module, as
+ we could create the signature using [module type of ...] *)
+
+
+(* Another problem with variance *)
+module M = struct type 'a t = 'a -> unit end;;
+module F(X:sig type #'a t end) =
+ struct type +'a s = S of 'b constraint 'a = 'b X.t end;; (* fail *)
+(*
+module N = F(M);;
+let o = N.S (object end);;
+let N.S o' = (o :> <m : int> M.t N.s);; (* unsound! *)
+*)
+
+(* And yet another *)
+type 'a q = Q;;
+type +'a t = 'b constraint 'a = 'b q;;
+(* shoud fail: we do not know for sure the variance of Queue.t *)
+
+type +'a t = T of 'a;;
+type +'a s = 'b constraint 'a = 'b t;; (* ok *)
+type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+type +'a u = 'a t;;
+type 'a t = T of ('a -> 'a);;
+type -'a s = 'b constraint 'a = 'b t;; (* ok *)
+type +'a s = 'b constraint 'a = 'b q t;; (* ok *)
+type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+
+
+(* the problem from lablgtk2 *)
+
+module Gobject = struct
+ type -'a obj
+end
+open Gobject;;
+
+class virtual ['a] item_container =
+ object
+ constraint 'a = < as_item : [>`widget] obj; .. >
+ method virtual add : 'a -> unit
+ end;;
+
+
+(* Another variance anomaly, should not expand t in g before checking *)
+type +'a t = unit constraint 'a = 'b list;;
+type _ g = G : 'a -> 'a t g;; (* fail *)
--- /dev/null
+
+# Characters 92-115:
+ type _ t = T : 'a -> 'a s t
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+ from the type parameters.
+# * * * Characters 131-134:
+ module F (S : sig type #'a s end) = struct
+ ^^^
+Syntax error: 'end' expected, the highlighted 'sig' might be unmatched
+# * * * * * Characters 296-374:
+ ........['a] c x =
+ object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
+Error: In this definition, a type variable cannot be deduced
+ from the type parameters.
+# type (_, _) eq = Eq : ('a, 'a) eq
+# val eq : 'a = <poly>
+# val eq : ('a Queue.t, 'b Queue.t) eq = Eq
+# Characters 4-33:
+ type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+ from the type parameters.
+# * * * * Characters 254-277:
+ type _ t = T : 'a -> 'a s t
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+ from the type parameters.
+# Characters 59-60:
+ module rec M : (S with type 'a s = unit) = M;;
+ ^
+Error: Unbound module type S
+# * * module M : sig type 'a t = 'a -> unit end
+# Characters 11-14:
+ module F(X:sig type #'a t end) =
+ ^^^
+Syntax error: 'end' expected, the highlighted 'sig' might be unmatched
+# * * * * type 'a q = Q
+# Characters 5-36:
+ type +'a t = 'b constraint 'a = 'b q;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable has a variance that
+ cannot be deduced from the type parameters.
+ It was expected to be unrestricted, but it is covariant.
+# type 'a t = T of 'a
+# type +'a s = 'b constraint 'a = 'b t
+# Characters 5-36:
+ type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable has a variance that
+ is not reflected by its occurrence in type parameters.
+ It was expected to be contravariant, but it is covariant.
+# type 'a u = 'a t
+# type 'a t = T of ('a -> 'a)
+# type -'a s = 'b constraint 'a = 'b t
+# type +'a s = 'b constraint 'a = 'b q t
+# Characters 5-38:
+ type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable has a variance that
+ cannot be deduced from the type parameters.
+ It was expected to be unrestricted, but it is covariant.
+# module Gobject : sig type -'a obj end
+# class virtual ['a] item_container :
+ object
+ constraint 'a = < as_item : [> `widget ] Gobject.obj; .. >
+ method virtual add : 'a -> unit
+ end
+# type +'a t = unit constraint 'a = 'b list
+# Characters 4-27:
+ type _ g = G : 'a -> 'a t g;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+ from the type parameters.
+#
--- /dev/null
+type (_, _) t =
+ Any : ('a, 'b) t
+ | Eq : ('a, 'a) t
+;;
+
+module M :
+sig
+ type s = private [> `A]
+ val eq : (s, [`A | `B]) t
+end =
+struct
+ type s = [`A | `B]
+ let eq = Eq
+end;;
+
+let f : (M.s, [`A | `B]) t -> string = function
+ | Any -> "Any"
+;;
+
+let () = print_endline (f M.eq) ;;
+
+module N :
+sig
+ type s = private < a : int; .. >
+ val eq : (s, <a : int; b : bool>) t
+end =
+struct
+ type s = <a : int; b : bool>
+ let eq = Eq
+end
+;;
+
+let f : (N.s, <a : int; b : bool>) t -> string = function
+ | Any -> "Any"
+;;
--- /dev/null
+
+# type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
+# module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
+# Characters 40-65:
+ .......................................function
+ | Any -> "Any"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+val f : (M.s, [ `A | `B ]) t -> string = <fun>
+# Exception: Match_failure ("//toplevel//", 14, 39).
+# module N :
+ sig
+ type s = private < a : int; .. >
+ val eq : (s, < a : int; b : bool >) t
+ end
+# Characters 50-75:
+ .................................................function
+ | Any -> "Any"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+val f : (N.s, < a : int; b : bool >) t -> string = <fun>
+#
--- /dev/null
+type (_, _) comp =
+ | Eq : ('a, 'a) comp
+ | Diff : ('a, 'b) comp
+;;
+
+module U = struct type t = T end;;
+
+module M : sig
+ type t = T
+ val comp : (U.t, t) comp
+end = struct
+ include U
+ let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+
+module U = struct type t = {x : int} end;;
+
+module M : sig
+ type t = {x : int}
+ val comp : (U.t, t) comp
+end = struct
+ include U
+ let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
--- /dev/null
+
+# type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
+# module U : sig type t = T end
+# module M : sig type t = T val comp : (U.t, t) comp end
+# Characters 1-34:
+ match M.comp with | Diff -> false;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+Exception: Match_failure ("//toplevel//", 13, 0).
+# module U : sig type t = { x : int; } end
+# module M : sig type t = { x : int; } val comp : (U.t, t) comp end
+# Characters 1-34:
+ match M.comp with | Diff -> false;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+Exception: Match_failure ("//toplevel//", 22, 0).
+#
--- /dev/null
+type 'a t = T of 'a
+type 'a s = S of 'a
+
+type (_, _) eq = Refl : ('a, 'a) eq;;
+
+let f : (int s, int t) eq -> unit = function Refl -> ();;
+
+module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
+struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
--- /dev/null
+
+# type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+# Characters 46-50:
+ let f : (int s, int t) eq -> unit = function Refl -> ();;
+ ^^^^
+Error: This pattern matches values of type (int s, int s) eq
+ but a pattern was expected which matches values of type
+ (int s, int t) eq
+ Type int s is not compatible with type int t
+# Characters 120-124:
+ struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+ ^^^^
+Error: This pattern matches values of type (ex#0 S.s, ex#1 S.t) eq
+ but a pattern was expected which matches values of type
+ (ex#0 S.s, ex#0 S.t) eq
+ The type constructor ex#0 would escape its scope
+#
--- /dev/null
+
+# type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+# Characters 46-50:
+ let f : (int s, int t) eq -> unit = function Refl -> ();;
+ ^^^^
+Error: This pattern matches values of type (int s, int s) eq
+ but a pattern was expected which matches values of type
+ (int s, int t) eq
+ Type int s is not compatible with type int t
+# module M :
+ functor (S : sig type 'a t = T of 'a type 'a s = T of 'a end) ->
+ sig val f : (a#0 S.s, a#0 S.t) eq -> unit end
+#
--- /dev/null
+type _ nat =
+ Zero : [`Zero] nat
+ | Succ : 'a nat -> [`Succ of 'a] nat;;
+type 'a pre_nat = [`Zero | `Succ of 'a];;
+type aux =
+ | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;;
+
+let f (Aux x) =
+ match x with
+ | Succ Zero -> "1"
+ | Succ (Succ Zero) -> "2"
+ | Succ (Succ (Succ Zero)) -> "3"
+ | Succ (Succ (Succ (Succ Zero))) -> "4"
+;;
--- /dev/null
+
+# type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+# type 'a pre_nat = [ `Succ of 'a | `Zero ]
+# type aux =
+ Aux :
+ [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat ->
+ aux
+# Characters 19-157:
+ ..match x with
+ | Succ Zero -> "1"
+ | Succ (Succ Zero) -> "2"
+ | Succ (Succ (Succ Zero)) -> "3"
+ | Succ (Succ (Succ (Succ Zero))) -> "4"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Succ (Succ (Succ (Succ (Succ _))))
+val f : aux -> string = <fun>
+#
--- /dev/null
+
+# type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+# type 'a pre_nat = [ `Succ of 'a | `Zero ]
+# type aux =
+ Aux :
+ [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat ->
+ aux
+# Characters 19-157:
+ ..match x with
+ | Succ Zero -> "1"
+ | Succ (Succ Zero) -> "2"
+ | Succ (Succ (Succ Zero)) -> "3"
+ | Succ (Succ (Succ (Succ Zero))) -> "4"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Succ (Succ (Succ (Succ (Succ _))))
+val f : aux -> string = <fun>
+#
let g : type a. a ty -> a =
let () = () in
fun x -> match x with Int y -> y;;
+
+(* Printing of anonymous variables *)
+
+module M = struct type _ t = int end;;
+module M = struct type _ t = T : int t end;;
+module N = M;;
+
+(* Principality *)
+
+(* adding a useless equation should not break inference *)
+let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b ->
+ let Eq = ab in
+ let x =
+ let Eq = aint in
+ if true then a else b
+ in ignore x
+;; (* ok *)
+
+let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
+ let Eq = ab in
+ let x =
+ let Eq = bint in
+ if true then a else b
+ in ignore x
+;; (* ok *)
# Characters 118-119:
let eval (D x) = x
^
-Error: This expression has type ex#16 t
- but an expression was expected of type ex#16 t
- The type constructor ex#16 would escape its scope
+Error: This expression has type a#2 t but an expression was expected of type
+ a#2 t
+ The type constructor a#2 would escape its scope
# Characters 174-175:
C ->
^
^^^^^^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type s t
-# Characters 224-237:
- | `A, BoolLit _ -> ()
- ^^^^^^^^^^^^^
-Error: This pattern matches values of type ([? `A ] as 'a) * bool t
- but a pattern was expected which matches values of type 'a * int t
+ Type int is not compatible with type s
+# module Polymorphic_variants :
+ sig
+ type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+ val eval : [ `A ] * 's t -> unit
+ end
# Characters 299-300:
| BoolLit b -> b
^
^^
Error: This expression has type (a, a) eq
but an expression was expected of type (a, b) eq
+ Type a is not compatible with type b
# val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
# val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
# type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
^
Error: This expression has type t = < foo : int; .. >
but an expression was expected of type < foo : int >
- Type ex#20 = < bar : int; .. > is not compatible with type < >
+ Type ex#17 = < bar : int; .. > is not compatible with type < >
The second object type has no method bar
# Characters 98-99:
(x:<foo:int;bar:int>)
^
Error: This expression has type t = < foo : int; .. >
but an expression was expected of type < bar : int; foo : int >
- Type ex#22 = < bar : int; .. > is not compatible with type
+ Type ex#19 = < bar : int; .. > is not compatible with type
< bar : int >
+ The first object type has an abstract row, it cannot be closed
# Characters 98-99:
(x:<foo:int;bar:int;..>)
^
Error: This expression has type < bar : int; foo : int; .. > as 'a
but an expression was expected of type 'a
- The type constructor ex#25 would escape its scope
+ The type constructor ex#22 would escape its scope
# val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
# val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
# type 'a ty = Int : int -> int ty
# val f : 'a ty -> 'a = <fun>
# val g : 'a ty -> 'a = <fun>
+# module M : sig type _ t = int end
+# module M : sig type _ t = T : int t end
+# module N : sig type 'a t = 'a M.t = T : int t end
+# val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun>
+# val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun>
#
# Characters 118-119:
let eval (D x) = x
^
-Error: This expression has type ex#16 t
- but an expression was expected of type ex#16 t
- The type constructor ex#16 would escape its scope
+Error: This expression has type a#2 t but an expression was expected of type
+ a#2 t
+ The type constructor a#2 would escape its scope
# Characters 174-175:
C ->
^
^^^^^^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type s t
-# Characters 224-237:
- | `A, BoolLit _ -> ()
- ^^^^^^^^^^^^^
-Error: This pattern matches values of type ([? `A ] as 'a) * bool t
- but a pattern was expected which matches values of type 'a * int t
+ Type int is not compatible with type s
+# module Polymorphic_variants :
+ sig
+ type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+ val eval : [ `A ] * 's t -> unit
+ end
# module Propagation :
sig
type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
# Characters 87-88:
let f = function A -> 1 | B -> 2
^
-Error: This pattern matches values of type b
- but a pattern was expected which matches values of type a
+Error: The variant type a has no constructor B
# type _ t = Int : int t
# val ky : 'a -> 'a -> 'a = <fun>
# val test : 'a t -> 'a = <fun>
^^
Error: This expression has type (a, a) eq
but an expression was expected of type (a, b) eq
+ Type a is not compatible with type b
# val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
# val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
# type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
^
Error: This expression has type t = < foo : int; .. >
but an expression was expected of type < foo : int >
- Type ex#20 = < bar : int; .. > is not compatible with type < >
+ Type ex#17 = < bar : int; .. > is not compatible with type < >
The second object type has no method bar
# Characters 98-99:
(x:<foo:int;bar:int>)
^
Error: This expression has type t = < foo : int; .. >
but an expression was expected of type < bar : int; foo : int >
- Type ex#22 = < bar : int; .. > is not compatible with type
+ Type ex#19 = < bar : int; .. > is not compatible with type
< bar : int >
+ The first object type has an abstract row, it cannot be closed
# Characters 98-99:
(x:<foo:int;bar:int;..>)
^
Error: This expression has type < bar : int; foo : int; .. > as 'a
but an expression was expected of type 'a
- The type constructor ex#25 would escape its scope
+ The type constructor ex#22 would escape its scope
# val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
# val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
# type 'a ty = Int : int -> int ty
# val f : 'a ty -> 'a = <fun>
# val g : 'a ty -> 'a = <fun>
+# module M : sig type _ t = int end
+# module M : sig type _ t = T : int t end
+# module N : sig type 'a t = 'a M.t = T : int t end
+# val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun>
+# val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun>
#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
-(* $Id: mixin.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
open StdLabels
open MoreLabels
-(* $Id: mixin2.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
(* Full fledge version, using objects to structure code *)
open StdLabels
-(* $Id: mixin3.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
(* Full fledge version, using objects to structure code *)
open StdLabels
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* PR#5835 *)
+
+let f ~x = x + 1;;
+f ?x:0;;
--- /dev/null
+
+# val f : x:int -> int = <fun>
+# Characters 5-6:
+ f ?x:0;;
+ ^
+Warning 43: the label x is not optional.
+- : int = 1
+#
--- /dev/null
+
+# val f : x:int -> int = <fun>
+# Characters 5-6:
+ f ?x:0;;
+ ^
+Warning 43: the label x is not optional.
+- : int = 1
+#
--- /dev/null
+(* PR#5907 *)
+
+type 'a t = 'a;;
+let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
--- /dev/null
+
+# type 'a t = 'a
+# Characters 42-43:
+ let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+ ^
+Error: This expression has type 'a list
+ but an expression was expected of type 'a t = 'a
+ The type variable 'a occurs inside 'a list
+# Characters 42-43:
+ let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+ ^
+Error: This expression has type 'a * 'b
+ but an expression was expected of type 'a t = 'a
+ The type variable 'a occurs inside 'a * 'b
+#
--- /dev/null
+type ab = [ `A | `B ];;
+let f (x : [`A]) = match x with #ab -> 1;;
+let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+
+let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
--- /dev/null
+
+# type ab = [ `A | `B ]
+# Characters 32-35:
+ let f (x : [`A]) = match x with #ab -> 1;;
+ ^^^
+Error: This pattern matches values of type [? `A | `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ The second variant type does not allow tag(s) `B
+# Characters 31-34:
+ let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+ ^^^
+Error: This pattern matches values of type [? `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ Types for tag `B are incompatible
+# Characters 34-36:
+ let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+ ^^
+Error: This pattern matches values of type [? `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ Types for tag `B are incompatible
+# Characters 50-52:
+ let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+ ^^
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = <fun>
+# Characters 47-49:
+ let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+ ^^
+Error: This pattern matches values of type [? `C ]
+ but a pattern was expected which matches values of type [ `A | `B ]
+ The second variant type does not allow tag(s) `C
+#
--- /dev/null
+
+# type ab = [ `A | `B ]
+# Characters 32-35:
+ let f (x : [`A]) = match x with #ab -> 1;;
+ ^^^
+Error: This pattern matches values of type [? `A | `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ The second variant type does not allow tag(s) `B
+# Characters 31-34:
+ let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+ ^^^
+Error: This pattern matches values of type [? `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ The second variant type does not allow tag(s) `B
+# Characters 34-36:
+ let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+ ^^
+Error: This pattern matches values of type [? `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ The second variant type does not allow tag(s) `B
+# Characters 50-52:
+ let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+ ^^
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = <fun>
+# Characters 47-49:
+ let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+ ^^
+Error: This pattern matches values of type [? `C ]
+ but a pattern was expected which matches values of type [ `A | `B ]
+ The second variant type does not allow tag(s) `C
+#
type u = private {mutable u:int};;
{u=3};;
fun x -> x.u <- 3;;
+
+(* Punning and abbreviations *)
+module M = struct
+ type t = {x: int; y: int}
+end;;
+
+let f {M.x; y} = x+y;;
+let r = {M.x=1; y=2};;
+let z = f r;;
+
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+
+(ZZZ.X : int option);;
+
+(* PR#5865 *)
+let f (x : Complex.t) = x.Complex.z;;
--- /dev/null
+
+# type t = { x : int; y : int; }
+# Characters 5-6:
+ {x=3;z=2};;
+ ^
+Error: Unbound record field z
+# Characters 9-10:
+ fun {x=3;z=2} -> ();;
+ ^
+Error: Unbound record field z
+# Characters 26-34:
+ {x=3; contents=2};;
+ ^^^^^^^^
+Error: The record field contents belongs to the type 'a ref
+ but is mixed here with fields of type t
+# type u = private { mutable u : int; }
+# Characters 0-5:
+ {u=3};;
+ ^^^^^
+Error: Cannot create values of the private type u
+# Characters 11-12:
+ fun x -> x.u <- 3;;
+ ^
+Error: Cannot assign field u of the private type u
+# module M : sig type t = { x : int; y : int; } end
+# val f : M.t -> int = <fun>
+# val r : M.t = {M.x = 1; y = 2}
+# val z : int = 3
+# type foo = { mutable y : int; }
+# Characters 17-18:
+ let f (r: int) = r.y <- 3;;
+ ^
+Error: This expression has type int but an expression was expected of type
+ foo
+# type foo = { y : int; z : int; }
+# type bar = { x : int; }
+# Characters 20-21:
+ let f (r: bar) = ({ r with z = 3 } : foo)
+ ^
+Error: This expression has type bar but an expression was expected of type
+ foo
+# Characters 16-21:
+ let r : foo = { ZZZ.x = 2 };;
+ ^^^^^
+Error: Unbound module ZZZ
+# Characters 2-7:
+ (ZZZ.X : int option);;
+ ^^^^^
+Error: Unbound module ZZZ
+# Characters 41-50:
+ let f (x : Complex.t) = x.Complex.z;;
+ ^^^^^^^^^
+Error: Unbound record field Complex.z
+#
# Characters 5-6:
{x=3;z=2};;
^
-Error: Unbound record field label z
+Error: Unbound record field z
# Characters 9-10:
fun {x=3;z=2} -> ();;
^
-Error: Unbound record field label z
+Error: Unbound record field z
# Characters 26-34:
{x=3; contents=2};;
^^^^^^^^
-Error: The record field label Pervasives.contents belongs to the type
- 'a ref but is mixed here with labels of type t
+Error: The record field contents belongs to the type 'a ref
+ but is mixed here with fields of type t
# type u = private { mutable u : int; }
# Characters 0-5:
{u=3};;
fun x -> x.u <- 3;;
^
Error: Cannot assign field u of the private type u
+# module M : sig type t = { x : int; y : int; } end
+# val f : M.t -> int = <fun>
+# val r : M.t = {M.x = 1; y = 2}
+# val z : int = 3
+# type foo = { mutable y : int; }
+# Characters 17-18:
+ let f (r: int) = r.y <- 3;;
+ ^
+Error: This expression has type int but an expression was expected of type
+ foo
+# type foo = { y : int; z : int; }
+# type bar = { x : int; }
+# Characters 20-21:
+ let f (r: bar) = ({ r with z = 3 } : foo)
+ ^
+Error: This expression has type bar but an expression was expected of type
+ foo
+# Characters 16-21:
+ let r : foo = { ZZZ.x = 2 };;
+ ^^^^^
+Error: Unbound module ZZZ
+# Characters 2-7:
+ (ZZZ.X : int option);;
+ ^^^^^
+Error: Unbound module ZZZ
+# Characters 41-50:
+ let f (x : Complex.t) = x.Complex.z;;
+ ^^^^^^^^^
+Error: Unbound record field Complex.z
#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
include ../../makefiles/Makefile.okbad
include ../../makefiles/Makefile.common
+++ /dev/null
-module M : sig
- type 'a t
- type u = u t and v = v t
- val f : int -> u
- val g : v -> bool
-end = struct
- type 'a t = 'a
- type u = int and v = bool
- let f x = x
- let g x = x
-end;;
-
-let h (x : int) : bool = M.g (M.f x);;
--- /dev/null
+type 't a = [ `A ]
+type 't wrap = 't constraint 't = [> 't wrap a ]
+type t = t a wrap
+
+module T = struct
+ let foo : 't wrap -> 't wrap -> unit = fun _ _ -> ()
+ let bar : ('a a wrap as 'a) = `A
+end
+
+module Good : sig
+ val bar: t
+ val foo: t -> t -> unit
+end = T
+
+module Bad : sig
+ val foo: t -> t -> unit
+ val bar: t
+end = T
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
include ../../makefiles/Makefile.toplevel
include ../../makefiles/Makefile.common
(* PR#4511 *)
let ko = let module M = struct end in fun _ -> ();;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+ struct type +'a t = private int end
+;;
+
+(* PR#6005 *)
+
+module type A = sig type t = X of int end;;
+type u = X of bool;;
+module type B = A with type t = u;; (* fail *)
+
+(* PR#5815 *)
+
+module type S = sig exception Foo of int exception Foo of bool end;;
# module M : sig val v : (#c as 'a) -> 'a end
# val id : 'a -> 'a = <fun>
# val ko : 'a -> unit = <fun>
+# Characters 64-99:
+ struct type +'a t = private int end
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type +'a t = private int end
+ is not included in
+ sig type -'a t = private int end
+ Type declarations do not match:
+ type +'a t = private int
+ is not included in
+ type -'a t = private int
+ Their variances do not agree.
+# module type A = sig type t = X of int end
+# type u = X of bool
+# Characters 23-33:
+ module type B = A with type t = u;; (* fail *)
+ ^^^^^^^^^^
+Error: This variant or record definition does not match that of type u
+ The types for field X are not equal.
+# module type S = sig exception Foo of bool end
#
# module M : sig val v : (#c as 'a) -> 'a end
# val id : 'a -> 'a = <fun>
# val ko : 'a -> unit = <fun>
+# Characters 64-99:
+ struct type +'a t = private int end
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type +'a t = private int end
+ is not included in
+ sig type -'a t = private int end
+ Type declarations do not match:
+ type +'a t = private int
+ is not included in
+ type -'a t = private int
+ Their variances do not agree.
+# module type A = sig type t = X of int end
+# type u = X of bool
+# Characters 23-33:
+ module type B = A with type t = u;; (* fail *)
+ ^^^^^^^^^^
+Error: This variant or record definition does not match that of type u
+ The types for field X are not equal.
+# module type S = sig exception Foo of bool end
#
--- /dev/null
+module type S = sig
+ type t
+ val x : t
+end;;
+
+module Good (X : S with type t := unit) = struct
+ let () = X.x
+end;;
+
+module type T = sig module M : S end;;
+
+module Bad (X : T with type M.t := unit) = struct
+ let () = X.M.x
+end;;
--- /dev/null
+
+# module type S = sig type t val x : t end
+# module Good : functor (X : sig val x : unit end) -> sig end
+# module type T = sig module M : S end
+# Characters 33-35:
+ module Bad (X : T with type M.t := unit) = struct
+ ^^
+Error: Syntax error
+#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.okbad
include $(BASEDIR)/makefiles/Makefile.common
is not a subtype of
point circle =
< center : point; move : int -> unit; set_center : point -> unit >
-Type point = point is not a subtype of color_point = color_point
+ Type point is not a subtype of color_point
# Characters 9-55:
fun x -> (x : color_point color_circle :> point circle);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
is not a subtype of
point circle =
< center : point; move : int -> unit; set_center : point -> unit >
-Type point = point is not a subtype of color_point = color_point
+ Type point is not a subtype of color_point
# class printable_point :
int ->
object
< leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
is not a subtype of
int_comparable = < leq : int_comparable -> bool; x : int >
-Type int_comparable = < leq : int_comparable -> bool; x : int >
-is not a subtype of
- int_comparable2 =
- < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
+ Type int_comparable = < leq : int_comparable -> bool; x : int >
+ is not a subtype of
+ int_comparable2 =
+ < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
# - : unit = ()
# class int_comparable3 :
int ->
is not a subtype of
point circle =
< center : point; move : int -> unit; set_center : point -> unit >
-Type point = point is not a subtype of color_point = color_point
+ Type point is not a subtype of color_point
# Characters 9-55:
fun x -> (x : color_point color_circle :> point circle);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
is not a subtype of
point circle =
< center : point; move : int -> unit; set_center : point -> unit >
-Type point = point is not a subtype of color_point = color_point
+ Type point is not a subtype of color_point
# class printable_point :
int ->
object
< leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
is not a subtype of
int_comparable = < leq : int_comparable -> bool; x : int >
-Type int_comparable = < leq : int_comparable -> bool; x : int >
-is not a subtype of
- int_comparable2 =
- < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
+ Type int_comparable = < leq : int_comparable -> bool; x : int >
+ is not a subtype of
+ int_comparable2 =
+ < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
# - : unit = ()
# class int_comparable3 :
int ->
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
let o' : <m:int> = Marshal.from_string s 0 in
let o'' : <m:int> = Marshal.from_string s 0 in
(Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);;
+
+(* Recursion (cf. PR#5291) *)
+
+class a = let _ = new b in object end
+and b = let _ = new a in object end;;
+
+class a = let _ = new a in object end;;
fun x -> (x : int -> bool :> 'a -> 'a);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type int -> bool is not a subtype of int -> int
+ Type bool is not a subtype of int
# Characters 9-40:
fun x -> (x : int -> bool :> int -> int);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type int -> bool is not a subtype of int -> int
+ Type bool is not a subtype of int
# - : < > -> < > = <fun>
# - : < .. > -> < > = <fun>
# val x : '_a list ref = {contents = []}
unit -> object method private m : int method n : int method o : int end
# - : int * int = (1, 1)
# class c : unit -> object method m : int end
-# - : int = 15
-# - : int = 16
+# - : int = 16
# - : int = 17
-# - : int * int * int = (18, 19, 20)
-# - : int * int * int * int * int = (21, 22, 23, 33, 33)
-# - : int * int * int * int * int = (24, 25, 26, 33, 33)
+# - : int = 18
+# - : int * int * int = (19, 20, 21)
+# - : int * int * int * int * int = (22, 23, 24, 33, 33)
+# - : int * int * int * int * int = (25, 26, 27, 33, 33)
+# Characters 42-69:
+ class a = let _ = new b in object end
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+# Characters 11-38:
+ class a = let _ = new a in object end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
#
fun x -> (x : int -> bool :> 'a -> 'a);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type int -> bool is not a subtype of int -> int
+ Type bool is not a subtype of int
# Characters 9-40:
fun x -> (x : int -> bool :> int -> int);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type int -> bool is not a subtype of int -> int
+ Type bool is not a subtype of int
# - : < > -> < > = <fun>
# - : < .. > -> < > = <fun>
# val x : '_a list ref = {contents = []}
unit -> object method private m : int method n : int method o : int end
# - : int * int = (1, 1)
# class c : unit -> object method m : int end
-# - : int = 15
-# - : int = 16
+# - : int = 16
# - : int = 17
-# - : int * int * int = (18, 19, 20)
-# - : int * int * int * int * int = (21, 22, 23, 33, 33)
-# - : int * int * int * int * int = (24, 25, 26, 33, 33)
+# - : int = 18
+# - : int * int * int = (19, 20, 21)
+# - : int * int * int * int * int = (22, 23, 24, 33, 33)
+# - : int * int * int * int * int = (25, 26, 27, 33, 33)
+# Characters 42-69:
+ class a = let _ = new b in object end
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+# Characters 11-38:
+ class a = let _ = new a in object end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
#
--- /dev/null
+class type c = object end;;
+module type S = sig class c: c end;;
--- /dev/null
+
+# class type c = object end
+# Characters 29-30:
+ module type S = sig class c: c end;;
+ ^
+Error: The class type c is not yet completely defined
+#
--- /dev/null
+class virtual name =
+object
+end
+
+and func (args_ty, ret_ty) =
+object(self)
+ inherit name
+
+ val mutable memo_args = None
+
+ method arguments =
+ match memo_args with
+ | Some xs -> xs
+ | None ->
+ let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+ memo_args <- Some args; args
+end
+
+and argument (func, ty) =
+object
+ inherit name
+end
+;;
--- /dev/null
+
+# Characters 253-257:
+ let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+ ^^^^
+Error: This expression has type < arguments : 'b; .. > as 'a
+ but an expression was expected of type 'a
+ Self type cannot escape its class
+#
--- /dev/null
+
+# Characters 253-257:
+ let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+ ^^^^
+Error: This expression has type < arguments : 'b; .. > as 'a
+ but an expression was expected of type 'a
+ Self type cannot escape its class
+#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.okbad
include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+module Classdef = struct
+ class virtual ['a, 'b, 'c] cl0 =
+ object
+ constraint 'c = < m : 'a -> 'b -> int; .. >
+ end
+
+ class virtual ['a, 'b] cl1 =
+ object
+ method virtual raise_trouble : int -> 'a
+ method virtual m : 'a -> 'b -> int
+ end
+
+ class virtual ['a, 'b] cl2 =
+ object
+ method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+ end
+end
+
+type refer1 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+type refer2 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+
+(* Actually this should succeed ... *)
+let f (x : refer1) = (x : refer2)
--- /dev/null
+module Classdef = struct
+ class virtual ['a, 'b, 'c] cl0 =
+ object
+ constraint 'c = < m : 'a -> 'b -> int; .. >
+ end
+
+ class virtual ['a, 'b] cl1 =
+ object
+ method virtual raise_trouble : int -> 'a
+ method virtual m : 'a -> 'b -> int
+ end
+
+ class virtual ['a, 'b] cl2 =
+ object
+ method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+ end
+end
+
+module M : sig
+ type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end = struct
+ type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
-(* $Id: poly.ml 12800 2012-07-30 18:59:07Z doligez $ *)
(*
Polymorphic methods are now available in the main branch.
Enjoy.
let p1 = new point ~x:10 ~y:13
let cp = new color_point ~x:12 ~y:(-5) ~color:"green"
let c = new circle p0 ~r:2
-let d = c#distance cp
+let d = floor (c#distance cp)
;;
let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >)
;;
(* PR#5224 *)
type 'x t = < f : 'y. 'y t >;;
+
+(* PR#6056, PR#6057 *)
+let using_match b =
+ let f =
+ match b with
+ | true -> fun x -> x
+ | false -> fun x -> x
+ in
+ f 0,f
+;;
+
+match (fun x -> x), fun x -> x with x, y -> x, y;;
+match fun x -> x with x -> x, x;;
-# * * * # type 'a t = { t : 'a; }
+# * * * # type 'a t = { t : 'a; }
# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
# val f : 'a list -> 'a fold = <fun>
# - : int = 6
val p1 : point = <obj>
val cp : color_point = <obj>
val c : circle = <obj>
-val d : float = 11.4536240470737098
+val d : float = 11.
# val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
# Characters 41-42:
let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
:> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f
+ Type 'c. 'e is not a subtype of 'a. 'g
# Characters 88-150:
= struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
:> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
< m : 'b. (< p : int; q : int; .. > as 'b) -> int >
+ Type < p : int; q : int; .. > as 'c is not a subtype of
+ < p : int; .. > as 'd
# val f2 :
< m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
< m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
:> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int >
+ Type < a : int > is not a subtype of < a : int; b : int >
# Characters 11-55:
let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < p : < a : int; b : int >; .. > is not a subtype of
< p : < a : int >; .. >
-The second object type has no method b
+ The second object type has no method b
# val f5 :
< m : 'a. [< `A of < p : int > ] as 'a > ->
< m : 'b. [< `A of < > ] as 'b > = <fun>
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of
< m : 'b. [< `A of < p : int > ] as 'b >
+ Type < > is not a subtype of < p : int >
# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
# Characters 9-16:
fun x -> (f x)#m;; (* Warning 18 *)
function Leaf x -> x | Node x -> depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'b. 'b t -> 'b which is less general than
- 'b 'a. 'a t -> 'b
+ 'a 'b. 'a t -> 'b
# val r : 'a list * '_b list ref = ([], {contents = []})
val q : unit -> 'a list * '_b list ref = <fun>
# val f : 'a -> 'a = <fun>
type 'x t = < f : 'y. 'y t >;;
^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of t, type 'y t should be 'x t
+# val using_match : bool -> int * ('a -> 'a) = <fun>
+# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
+# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
#
-# * * * # type 'a t = { t : 'a; }
+# * * * # type 'a t = { t : 'a; }
# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
# val f : 'a list -> 'a fold = <fun>
# - : int = 6
val p1 : point = <obj>
val cp : color_point = <obj>
val c : circle = <obj>
-val d : float = 11.4536240470737098
+val d : float = 11.
# val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
# Characters 41-42:
let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
:> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f
+ Type 'c. 'e is not a subtype of 'a. 'g
# Characters 88-150:
= struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
:> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
< m : 'b. (< p : int; q : int; .. > as 'b) -> int >
+ Type < p : int; q : int; .. > as 'c is not a subtype of
+ < p : int; .. > as 'd
# val f2 :
< m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
< m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
:> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int >
+ Type < a : int > is not a subtype of < a : int; b : int >
# Characters 11-55:
let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < p : < a : int; b : int >; .. > is not a subtype of
< p : < a : int >; .. >
-The second object type has no method b
+ The second object type has no method b
# val f5 :
< m : 'a. [< `A of < p : int > ] as 'a > ->
< m : 'b. [< `A of < > ] as 'b > = <fun>
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of
< m : 'b. [< `A of < p : int > ] as 'b >
+ Type < > is not a subtype of < p : int >
# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
function Leaf x -> x | Node x -> depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'b. 'b t -> 'b which is less general than
- 'b 'a. 'a t -> 'b
+ 'a 'b. 'a t -> 'b
# val r : 'a list * '_b list ref = ([], {contents = []})
val q : unit -> 'a list * '_b list ref = <fun>
# val f : 'a -> 'a = <fun>
type 'x t = < f : 'y. 'y t >;;
^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of t, type 'y t should be 'x t
+# val using_match : bool -> int * ('a -> 'a) = <fun>
+# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
+# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
default:
@printf " ... testing 'pr3918':"
- @($(OCAMLC) -c pr3918a.mli && $(OCAMLC) -c pr3918b.mli && $(OCAMLC) -c pr3918c.ml && echo " => passed") || echo " => failed"
+ @($(OCAMLC) -c pr3918a.mli \
+ && $(OCAMLC) -c pr3918b.mli \
+ && $(OCAMLC) -c pr3918c.ml \
+ && echo " => passed") || echo " => failed"
clean: defaultclean
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.okbad
include $(BASEDIR)/makefiles/Makefile.common
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.okbad
include $(BASEDIR)/makefiles/Makefile.common
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
type t = M'.t
val mk : int -> t
end = M';;
+
+module M : sig type 'a t = private T of 'a end =
+ struct type 'a t = T of 'a end;;
+
+module M1 : sig type 'a t = 'a M.t = private T of 'a end =
+ struct type 'a t = 'a M.t = private T of 'a end;;
+
+(* PR#6090 *)
+module Test = struct type t = private A end
+module Test2 : module type of Test with type t = Test.t = Test;;
+let f (x : Test.t) = (x : Test2.t);;
+let f Test2.A = ();;
+let a = Test2.A;; (* fail *)
+(* The following should fail from a semantical point of view,
+ but allow it for backward compatibility *)
+module Test2 : module type of Test with type t = private Test.t = Test;;
# module M' :
sig type t_priv = private T of int type t = t_priv val mk : int -> t end
# module M3' : sig type t = M'.t val mk : int -> t end
+# module M : sig type 'a t = private T of 'a end
+# module M1 : sig type 'a t = 'a M.t = private T of 'a end
+# module Test : sig type t = private A end
+module Test2 : sig type t = Test.t = private A end
+# val f : Test.t -> Test2.t = <fun>
+# val f : Test2.t -> unit = <fun>
+# Characters 8-15:
+ let a = Test2.A;; (* fail *)
+ ^^^^^^^
+Error: Cannot create values of the private type Test2.t
+# * module Test2 : sig type t = Test.t = private A end
#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.okbad
include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
+COMPFLAGS = -rectypes
--- /dev/null
+module M : sig
+ type 'a t
+ type u = u t and v = v t
+ val f : int -> u
+ val g : v -> bool
+end = struct
+ type 'a t = 'a
+ type u = int and v = bool
+ let f x = x
+ let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -short-paths
--- /dev/null
+module rec A : sig
+ type t
+end = struct
+ type t = { a : unit; b : unit }
+ let _ = { a = () }
+end
+;;
--- /dev/null
+
+# Characters 82-92:
+ let _ = { a = () }
+ ^^^^^^^^^^
+Error: Some record fields are undefined: b
+#
--- /dev/null
+module Core = struct
+ module Int = struct
+ module T = struct
+ type t = int
+ let compare = compare
+ let (+) x y = x + y
+ end
+ include T
+ module Map = Map.Make(T)
+ end
+
+ module Std = struct
+ module Int = Int
+ end
+end
+;;
+
+open Core.Std
+;;
+
+let x = Int.Map.empty ;;
+let y = x + x ;;
+
+(* Avoid ambiguity *)
+
+module M = struct type t = A type u = C end
+module N = struct type t = B end
+open M open N;;
+A;;
+B;;
+C;;
+
+include M open M;;
+C;;
+
+module L = struct type v = V end
+open L;;
+V;;
+module L = struct type v = V end
+open L;;
+V;;
+
+
+type t1 = A;;
+module M1 = struct type u = v and v = t1 end;;
+module N1 = struct type u = v and v = M1.v end;;
+type t1 = B;;
+module N2 = struct type u = v and v = M1.v end;;
--- /dev/null
+
+# module Core :
+ sig
+ module Int :
+ sig
+ module T :
+ sig
+ type t = int
+ val compare : 'a -> 'a -> t
+ val ( + ) : t -> t -> t
+ end
+ type t = int
+ val compare : 'a -> 'a -> t
+ val ( + ) : t -> t -> t
+ module Map :
+ sig
+ type key = t
+ type 'a t = 'a Map.Make(T).t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val mem : key -> 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val singleton : key -> 'a -> 'a t
+ val remove : key -> 'a t -> 'a t
+ val merge :
+ (key -> 'a option -> 'b option -> 'c option) ->
+ 'a t -> 'b t -> 'c t
+ val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+ val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+ val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal : 'a t -> key
+ val bindings : 'a t -> (key * 'a) list
+ val min_binding : 'a t -> key * 'a
+ val max_binding : 'a t -> key * 'a
+ val choose : 'a t -> key * 'a
+ val split : key -> 'a t -> 'a t * 'a option * 'a t
+ val find : key -> 'a t -> 'a
+ val map : ('a -> 'b) -> 'a t -> 'b t
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+ end
+ end
+ module Std :
+ sig
+ module Int :
+ sig
+ module T :
+ sig
+ type t = int
+ val compare : 'a -> 'a -> t
+ val ( + ) : t -> t -> t
+ end
+ type t = int
+ val compare : 'a -> 'a -> t
+ val ( + ) : t -> t -> t
+ module Map :
+ sig
+ type key = t
+ type 'a t = 'a Map.Make(T).t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val mem : key -> 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val singleton : key -> 'a -> 'a t
+ val remove : key -> 'a t -> 'a t
+ val merge :
+ (key -> 'a option -> 'b option -> 'c option) ->
+ 'a t -> 'b t -> 'c t
+ val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+ val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+ val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal : 'a t -> key
+ val bindings : 'a t -> (key * 'a) list
+ val min_binding : 'a t -> key * 'a
+ val max_binding : 'a t -> key * 'a
+ val choose : 'a t -> key * 'a
+ val split : key -> 'a t -> 'a t * 'a option * 'a t
+ val find : key -> 'a t -> 'a
+ val map : ('a -> 'b) -> 'a t -> 'b t
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+ end
+ end
+ end
+ end
+# # val x : 'a Int.Map.t = <abstr>
+# Characters 8-9:
+ let y = x + x ;;
+ ^
+Error: This expression has type 'a Int.Map.t
+ but an expression was expected of type int
+# module M : sig type t = A type u = C end
+module N : sig type t = B end
+# - : M.t = A
+# - : N.t = B
+# - : u = C
+# type t = M.t = A
+type u = M.u = C
+# - : u = C
+# module L : sig type v = V end
+# - : v = V
+# module L : sig type v = V end
+# - : v = V
+# type t1 = A
+# module M1 : sig type u = v and v = t1 end
+# module N1 : sig type u = v and v = t1 end
+# type t1 = B
+# module N2 : sig type u = v and v = N1.v end
+#
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -w A
--- /dev/null
+open CamlinternalOO;;
+type _ choice = Left : label choice | Right : tag choice;;
+let f : label choice -> bool = function Left -> true;; (* warn *)
--- /dev/null
+
+# # type _ choice =
+ Left : CamlinternalOO.label choice
+ | Right : CamlinternalOO.tag choice
+# Characters 31-52:
+ let f : label choice -> bool = function Left -> true;; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Right
+val f : CamlinternalOO.label choice -> bool = <fun>
+#
--- /dev/null
+(* Use type information *)
+module M1 = struct
+ type t = {x: int; y: int}
+ type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+ open M1
+ let f1 (r:t) = r.x (* ok *)
+ let f2 r = ignore (r:t); r.x (* non principal *)
+
+ let f3 (r: t) =
+ match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+ open M1
+ let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+ open M1
+ let f r =
+ ignore (r: t);
+ match r with
+ {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+ type t = {x:int}
+ type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+let f ({x}:M.t) = x;; (* warning *)
+
+module M = struct
+ type t = {x: int; y: int}
+end;;
+module N = struct
+ type u = {x: bool; y: bool}
+end;;
+module OK = struct
+ open M
+ open N
+ let f (r:M.t) = r.x
+end;;
+
+module M = struct
+ type t = {x:int}
+ module N = struct type s = t = {x:int} end
+ type u = {x:bool}
+end;;
+module OK = struct
+ open M.N
+ let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+ type u = {x:bool;y:int;z:char}
+ type t = {x:int;y:bool}
+end;;
+module OK = struct
+ open M
+ let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+ open M
+ let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+ type u = {x:int;y:bool}
+ type t = {x:bool;y:int;z:char}
+ let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+ type foo = {x:int; y:int}
+ type bar = {x:int}
+ let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+ type foo = { x: int; y: int }
+ type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+ open M
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+ include M
+ type other = { a: int; b: int }
+end;;
+module F6 = struct
+ open M
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+ open M
+ let r = {x=1; y=2}
+ let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+ type t = {x:int; yyy:int}
+ let a : t = {x=1;yyz=2}
+end;;
+
+(* PR#6004 *)
+
+type t = A
+type s = A
+
+class f (_ : t) = object end;;
+class g = f A;; (* ok *)
+
+class f (_ : 'a) (_ : 'a) = object end;;
+class g = f (A : t) A;; (* warn with -principal *)
+
+
+(* PR#5980 *)
+
+module Shadow1 = struct
+ type t = {x: int}
+ module M = struct
+ type s = {x: string}
+ end
+ open M (* this open is unused, it isn't reported as shadowing 'x' *)
+ let y : t = {x = 0}
+end;;
+module Shadow2 = struct
+ type t = {x: int}
+ module M = struct
+ type s = {x: string}
+ end
+ open M (* this open shadows label 'x' *)
+ let y = {x = ""}
+end;;
--- /dev/null
+
+# module M1 :
+ sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+# Characters 49-50:
+ let f1 (r:t) = r.x (* ok *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 18: this type-based field disambiguation is not principal.
+Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 151-152:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of y required disambiguation.
+Characters 81-103:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type u.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 27: unused variable x.
+module OK :
+ sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+# Characters 55-61:
+ let f r = match r with {x; y} -> y + y
+ ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+ let f r = match r with {x; y} -> y + y
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+# Characters 85-91:
+ {x; y} -> y + y
+ ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 85-91:
+ {x; y} -> y + y
+ ^^^^^^
+Error: This pattern matches values of type M1.u
+ but a pattern was expected which matches values of type M1.t
+# module M : sig type t = { x : int; } type u = { x : bool; } end
+# Characters 18-21:
+ let f (r:M.t) = r.M.x;; (* ok *)
+ ^^^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = <fun>
+# Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not
+be selected if the type becomes unknown.
+Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = <fun>
+# Characters 8-9:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 7-10:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = <fun>
+# module M : sig type t = { x : int; y : int; } end
+# module N : sig type u = { x : bool; y : bool; } end
+# Characters 57-58:
+ let f (r:M.t) = r.x
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 30-36:
+ open N
+ ^^^^^^
+Warning 33: unused open N.
+Characters 25-47:
+ ...... M
+ open N
+ let f (r...........
+Warning 34: unused type u.
+module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type t = { x : int; }
+ module N : sig type s = t = { x : int; } end
+ type u = { x : bool; }
+ end
+# module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type u = { x : bool; y : int; z : char; }
+ type t = { x : int; y : bool; }
+ end
+# Characters 37-38:
+ let f {x;z} = x,z
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 36-41:
+ let f {x;z} = x,z
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 87-105:
+ Warning 34: unused type t.
+module OK : sig val f : M.u -> bool * char end
+# Characters 38-52:
+ let r = {x=true;z='z'}
+ ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+# Characters 90-91:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 95-96:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of y required disambiguation.
+module OK :
+ sig
+ type u = { x : int; y : bool; }
+ type t = { x : bool; y : int; z : char; }
+ val r : u
+ end
+# Characters 111-112:
+ let b : bar = {x=3; y=4}
+ ^
+Error: The record type bar has no field y
+# module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+ let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+ ^^^
+Error: The record field N.y belongs to the type N.bar
+ but is mixed here with fields of type M.foo
+# module MN :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = N.bar = { x : int; y : int; }
+ end
+module NM :
+ sig
+ type bar = N.bar = { x : int; y : int; }
+ type foo = M.foo = { x : int; y : int; }
+ end
+# Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+ but is mixed here with fields of type MN.bar = N.bar
+# module M :
+ sig
+ type foo = { x : int; y : int; }
+ type bar = { x : int; y : int; z : int; }
+ end
+# Characters 65-66:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 72-73:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Error: The record type M.foo has no field z
+# module M :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = M.bar = { x : int; y : int; z : int; }
+ type other = { a : int; b : int; }
+ end
+# Characters 66-67:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 73-74:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Error: The record type M.foo has no field a
+# Characters 39-40:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 44-45:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of y required disambiguation.
+Characters 67-68:
+ let r: other = {x=1; y=2}
+ ^
+Error: The record type M.other has no field x
+# module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+ let f (r : B.t) = r.A.x;; (* fail *)
+ ^^^
+Error: The field A.x belongs to the record type A.t
+ but a field was expected belonging to the record type B.t
+# Characters 88-91:
+ let a : t = {x=1;yyz=2}
+ ^^^
+Error: The record type t has no field yyz
+Did you mean yyy?
+# type t = A
+type s = A
+class f : t -> object end
+# Characters 12-13:
+ class g = f A;; (* ok *)
+ ^
+Warning 42: this use of A required disambiguation.
+class g : f
+# class f : 'a -> 'a -> object end
+# Characters 13-14:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A required disambiguation.
+Characters 20-21:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 18: this type-based constructor disambiguation is not principal.
+Characters 20-21:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A required disambiguation.
+class g : f
+# Characters 199-200:
+ let y : t = {x = 0}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 114-120:
+ open M (* this open is unused, it isn't reported as shadowing 'x' *)
+ ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : t
+ end
+# Characters 97-103:
+ open M (* this open shadows label 'x' *)
+ ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+ let y = {x = ""}
+ ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : M.s
+ end
+#
--- /dev/null
+
+# module M1 :
+ sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+# Characters 49-50:
+ let f1 (r:t) = r.x (* ok *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 151-152:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of y required disambiguation.
+Characters 81-103:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type u.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 27: unused variable x.
+module OK :
+ sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+# Characters 55-61:
+ let f r = match r with {x; y} -> y + y
+ ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+ let f r = match r with {x; y} -> y + y
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+# Characters 86-87:
+ {x; y} -> y + y
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 89-90:
+ {x; y} -> y + y
+ ^
+Warning 42: this use of y required disambiguation.
+Characters 81-103:
+ ... {x; y} -> y + y
+ en..............................
+Warning 34: unused type u.
+Characters 86-87:
+ {x; y} -> y + y
+ ^
+Warning 27: unused variable x.
+module F2 : sig val f : M1.t -> int end
+# module M : sig type t = { x : int; } type u = { x : bool; } end
+# Characters 18-21:
+ let f (r:M.t) = r.M.x;; (* ok *)
+ ^^^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = <fun>
+# Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not
+be selected if the type becomes unknown.
+Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = <fun>
+# Characters 8-9:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 7-10:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = <fun>
+# module M : sig type t = { x : int; y : int; } end
+# module N : sig type u = { x : bool; y : bool; } end
+# Characters 57-58:
+ let f (r:M.t) = r.x
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 30-36:
+ open N
+ ^^^^^^
+Warning 33: unused open N.
+Characters 25-47:
+ ...... M
+ open N
+ let f (r...........
+Warning 34: unused type u.
+module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type t = { x : int; }
+ module N : sig type s = t = { x : int; } end
+ type u = { x : bool; }
+ end
+# module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type u = { x : bool; y : int; z : char; }
+ type t = { x : int; y : bool; }
+ end
+# Characters 37-38:
+ let f {x;z} = x,z
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 36-41:
+ let f {x;z} = x,z
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 87-105:
+ Warning 34: unused type t.
+module OK : sig val f : M.u -> bool * char end
+# Characters 38-52:
+ let r = {x=true;z='z'}
+ ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+# Characters 90-91:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 95-96:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of y required disambiguation.
+module OK :
+ sig
+ type u = { x : int; y : bool; }
+ type t = { x : bool; y : int; z : char; }
+ val r : u
+ end
+# Characters 111-112:
+ let b : bar = {x=3; y=4}
+ ^
+Error: The record type bar has no field y
+# module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+ let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+ ^^^
+Error: The record field N.y belongs to the type N.bar
+ but is mixed here with fields of type M.foo
+# module MN :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = N.bar = { x : int; y : int; }
+ end
+module NM :
+ sig
+ type bar = N.bar = { x : int; y : int; }
+ type foo = M.foo = { x : int; y : int; }
+ end
+# Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+ but is mixed here with fields of type MN.bar = N.bar
+# module M :
+ sig
+ type foo = { x : int; y : int; }
+ type bar = { x : int; y : int; z : int; }
+ end
+# Characters 65-66:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 72-73:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Error: The record type M.foo has no field z
+# module M :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = M.bar = { x : int; y : int; z : int; }
+ type other = { a : int; b : int; }
+ end
+# Characters 66-67:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 73-74:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Error: The record type M.foo has no field a
+# Characters 39-40:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 44-45:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of y required disambiguation.
+Characters 67-68:
+ let r: other = {x=1; y=2}
+ ^
+Error: The record type M.other has no field x
+# module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+ let f (r : B.t) = r.A.x;; (* fail *)
+ ^^^
+Error: The field A.x belongs to the record type A.t
+ but a field was expected belonging to the record type B.t
+# Characters 88-91:
+ let a : t = {x=1;yyz=2}
+ ^^^
+Error: The record type t has no field yyz
+Did you mean yyy?
+# type t = A
+type s = A
+class f : t -> object end
+# Characters 12-13:
+ class g = f A;; (* ok *)
+ ^
+Warning 42: this use of A required disambiguation.
+class g : f
+# class f : 'a -> 'a -> object end
+# Characters 13-14:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A required disambiguation.
+Characters 20-21:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A required disambiguation.
+class g : f
+# Characters 199-200:
+ let y : t = {x = 0}
+ ^
+Warning 42: this use of x required disambiguation.
+Characters 114-120:
+ open M (* this open is unused, it isn't reported as shadowing 'x' *)
+ ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : t
+ end
+# Characters 97-103:
+ open M (* this open shadows label 'x' *)
+ ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+ let y = {x = ""}
+ ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : M.s
+ end
+#
--- /dev/null
+#########################################################################
+# #
+# OCaml #
+# #
+# Alain Frisch, LexiFi #
+# #
+# Copyright 2012 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+MODULES=testing misc
+INCLUDES= -I $(OTOPDIR)/utils
+ADD_COMPFLAGS=$(INCLUDES)
+CMO_FILES+="misc.cmo"
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+let edit_distance = Misc.edit_distance
+
+let show_cutoff n =
+ if n = max_int then "max_int" else Printf.sprintf "%d" n
+;;
+
+let test =
+ let counter = ref 0 in
+ fun a b cutoff expected ->
+ let show_result = function
+ | None -> "None"
+ | Some d -> "Some " ^ string_of_int d in
+ incr counter;
+ Printf.printf "[%02d] (edit_distance %S %S %s), expected %s\n"
+ !counter a b (show_cutoff cutoff) (show_result expected);
+ let result = edit_distance a b cutoff in
+ if result = expected
+ then print_endline "OK"
+ else Printf.printf "FAIL: got %s\n%!" (show_result result)
+
+let () =
+ test "a" "a" 1 (Some 0);
+ test "a" "a" 0 (Some 0);
+ test "a" "b" 1 (Some 1);
+ test "a" "b" 0 None;
+ test "add" "adad" 3 (Some 1);
+ test "delete" "delte" 3 (Some 1);
+ test "subst" "sabst" 3 (Some 1);
+ test "swap" "sawp" 3 (Some 1);
+ test "abbb" "bbba" 3 (Some 2);
+ test "abbb" "bbba" 1 None;
+
+ (* check for bugs where a small common suffix, or common prefix, is
+ enough to make the distance goes down *)
+ test "xyzwabc" "mnpqrabc" 10 (Some 5);
+ test "abcxyzw" "abcmnpqr" 10 (Some 5);
+
+ (* check that using "max_int" as cutoff works *)
+ test "a" "a" max_int (Some 0);
+ test "a" "b" max_int (Some 1);
+ test "abc" "ade" max_int (Some 2);
+
+ (* check empty strings*)
+ test "" "" 3 (Some 0);
+ test "" "abc" 3 (Some 3);
+ test "abcd" "" 3 None;
+
+ ()
+
--- /dev/null
+[01] (edit_distance "a" "a" 1), expected Some 0
+OK
+[02] (edit_distance "a" "a" 0), expected Some 0
+OK
+[03] (edit_distance "a" "b" 1), expected Some 1
+OK
+[04] (edit_distance "a" "b" 0), expected None
+OK
+[05] (edit_distance "add" "adad" 3), expected Some 1
+OK
+[06] (edit_distance "delete" "delte" 3), expected Some 1
+OK
+[07] (edit_distance "subst" "sabst" 3), expected Some 1
+OK
+[08] (edit_distance "swap" "sawp" 3), expected Some 1
+OK
+[09] (edit_distance "abbb" "bbba" 3), expected Some 2
+OK
+[10] (edit_distance "abbb" "bbba" 1), expected None
+OK
+[11] (edit_distance "xyzwabc" "mnpqrabc" 10), expected Some 5
+OK
+[12] (edit_distance "abcxyzw" "abcmnpqr" 10), expected Some 5
+OK
+[13] (edit_distance "a" "a" max_int), expected Some 0
+OK
+[14] (edit_distance "a" "b" max_int), expected Some 1
+OK
+[15] (edit_distance "abc" "ade" max_int), expected Some 2
+OK
+[16] (edit_distance "" "" 3), expected Some 0
+OK
+[17] (edit_distance "" "abc" 3), expected Some 3
+OK
+[18] (edit_distance "abcd" "" 3), expected None
+OK
+
+All tests succeeded.
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
BASEDIR=../..
FLAGS=-w A
EXECNAME=./program
run-all:
@for file in *.ml; do \
printf " ... testing '$$file':"; \
- $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2> `basename $$file ml`result; \
- $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \
+ F="`basename $$file .ml`"; \
+ $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2>$$F.result; \
+ $(DIFF) $$F.reference $$F.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
done;
promote: defaultpromote
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
(* C *)
-File "w01.ml", line 4, characters 12-14:
+File "w01.ml", line 15, characters 12-14:
Warning 2: this is not the end of a comment.
-File "w01.ml", line 10, characters 0-3:
+File "w01.ml", line 21, characters 0-3:
Warning 5: this function application is partial,
maybe some arguments are missing.
-File "w01.ml", line 20, characters 4-5:
+File "w01.ml", line 31, characters 4-5:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
0
-File "w01.ml", line 25, characters 0-1:
+File "w01.ml", line 36, characters 0-1:
Warning 10: this expression should have type unit.
-File "w01.ml", line 9, characters 8-9:
+File "w01.ml", line 20, characters 8-9:
Warning 27: unused variable y.
-File "w01.ml", line 32, characters 2-3:
+File "w01.ml", line 43, characters 2-3:
Warning 11: this match case is unused.
--- /dev/null
+tests/typing-fstclassmod
+tests/typing-gadts
+tests/typing-implicit_unpack
+tests/typing-labels
+tests/typing-misc
+tests/typing-modules
+tests/typing-modules-bugs
+tests/typing-objects
+tests/typing-objects-bugs
+tests/typing-poly
+tests/typing-poly-bugs
+tests/typing-polyvariants-bugs
+tests/typing-polyvariants-bugs-2
+tests/typing-private
+tests/typing-private-bugs
+tests/typing-recmod
+tests/typing-rectypes-bugs
+tests/typing-short-paths
+tests/typing-signatures
+tests/typing-sigsubst
+tests/typing-typeparam
+tests/typing-warnings
depend.cmi : ../parsing/parsetree.cmi
profiling.cmi :
-typedtreeIter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
+tast_iter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \
../parsing/parsetree.cmi ../parsing/longident.cmi
addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi
-cmt2annot.cmo : untypeast.cmi typedtreeIter.cmi ../typing/typedtree.cmi \
- ../typing/stypes.cmi pprintast.cmo ../typing/path.cmi \
- ../typing/oprint.cmi ../parsing/location.cmi ../typing/ident.cmi \
- ../typing/env.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \
+cmt2annot.cmo : untypeast.cmi ../typing/types.cmi ../typing/typedtree.cmi \
+ tast_iter.cmi ../typing/stypes.cmi ../parsing/pprintast.cmi \
+ ../typing/path.cmi ../typing/oprint.cmi ../parsing/location.cmi \
+ ../typing/ident.cmi ../typing/envaux.cmi ../typing/env.cmi \
+ ../utils/config.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \
../typing/annot.cmi
-cmt2annot.cmx : untypeast.cmx typedtreeIter.cmx ../typing/typedtree.cmx \
- ../typing/stypes.cmx pprintast.cmx ../typing/path.cmx \
- ../typing/oprint.cmx ../parsing/location.cmx ../typing/ident.cmx \
- ../typing/env.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \
+cmt2annot.cmx : untypeast.cmx ../typing/types.cmx ../typing/typedtree.cmx \
+ tast_iter.cmx ../typing/stypes.cmx ../parsing/pprintast.cmx \
+ ../typing/path.cmx ../typing/oprint.cmx ../parsing/location.cmx \
+ ../typing/ident.cmx ../typing/envaux.cmx ../typing/env.cmx \
+ ../utils/config.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \
../typing/annot.cmi
cvt_emit.cmo :
cvt_emit.cmx :
depend.cmi
dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \
- ../bytecomp/instruct.cmi ../typing/ident.cmi ../bytecomp/emitcode.cmi \
- ../utils/config.cmi ../bytecomp/cmo_format.cmi \
- ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi
+ ../bytecomp/instruct.cmi ../typing/ident.cmi ../utils/config.cmi \
+ ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \
+ ../parsing/asttypes.cmi
dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \
- ../bytecomp/instruct.cmx ../typing/ident.cmx ../bytecomp/emitcode.cmx \
- ../utils/config.cmx ../bytecomp/cmo_format.cmi \
- ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi
+ ../bytecomp/instruct.cmx ../typing/ident.cmx ../utils/config.cmx \
+ ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \
+ ../parsing/asttypes.cmi
+eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
+ ../parsing/location.cmi ../parsing/asttypes.cmi
+eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
+ ../parsing/location.cmx ../parsing/asttypes.cmi
myocamlbuild_config.cmo :
myocamlbuild_config.cmx :
objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \
ocaml299to3.cmx :
ocamlcp.cmo : ../driver/main_args.cmi
ocamlcp.cmx : ../driver/main_args.cmx
-ocamldep.cmo : ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \
- ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \
+ocamldep.cmo : ../parsing/syntaxerr.cmi ../driver/pparse.cmi \
+ ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \
../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \
- ../utils/config.cmi ../utils/clflags.cmi
-ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
- ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \
+ ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi
+ocamldep.cmx : ../parsing/syntaxerr.cmx ../driver/pparse.cmx \
+ ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \
../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \
- ../utils/config.cmx ../utils/clflags.cmx
+ ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx
ocamlmklib.cmo : myocamlbuild_config.cmo
ocamlmklib.cmx : myocamlbuild_config.cmx
ocamlmktop.cmo : ../utils/ccomp.cmi
ocamloptp.cmo : ../driver/main_args.cmi
ocamloptp.cmx : ../driver/main_args.cmx
ocamlprof.cmo : ../utils/warnings.cmi ../parsing/syntaxerr.cmi \
- ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \
- ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \
- ../utils/clflags.cmi
+ ../parsing/parsetree.cmi ../parsing/parse.cmi ../parsing/location.cmi \
+ ../parsing/lexer.cmi
ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \
- ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \
- ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \
- ../utils/clflags.cmx
+ ../parsing/parsetree.cmi ../parsing/parse.cmx ../parsing/location.cmx \
+ ../parsing/lexer.cmx
opnames.cmo :
opnames.cmx :
-pprintast.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
- ../parsing/location.cmi ../parsing/asttypes.cmi
-pprintast.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
- ../parsing/location.cmx ../parsing/asttypes.cmi
primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
profiling.cmo : profiling.cmi
read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
scrapelabels.cmo :
scrapelabels.cmx :
-typedtreeIter.cmo : ../typing/typedtree.cmi ../utils/misc.cmi \
- ../parsing/asttypes.cmi typedtreeIter.cmi
-typedtreeIter.cmx : ../typing/typedtree.cmx ../utils/misc.cmx \
- ../parsing/asttypes.cmi typedtreeIter.cmi
+tast_iter.cmo : ../typing/typedtree.cmi ../parsing/asttypes.cmi \
+ tast_iter.cmi
+tast_iter.cmx : ../typing/typedtree.cmx ../parsing/asttypes.cmi \
+ tast_iter.cmi
untypeast.cmo : ../typing/typedtree.cmi ../typing/path.cmi \
- ../parsing/parsetree.cmi ../utils/misc.cmi ../parsing/longident.cmi \
- ../typing/ident.cmi ../parsing/asttypes.cmi untypeast.cmi
+ ../parsing/parsetree.cmi ../parsing/longident.cmi ../typing/ident.cmi \
+ ../parsing/asttypes.cmi untypeast.cmi
untypeast.cmx : ../typing/typedtree.cmx ../typing/path.cmx \
- ../parsing/parsetree.cmi ../utils/misc.cmx ../parsing/longident.cmx \
- ../typing/ident.cmx ../parsing/asttypes.cmi untypeast.cmi
+ ../parsing/parsetree.cmi ../parsing/longident.cmx ../typing/ident.cmx \
+ ../parsing/asttypes.cmi untypeast.cmi
addlabels
myocamlbuild_config.ml
objinfo_helper
-objinfo_helper.exe
read_cmt
-read_cmt.bak
+read_cmt.opt
# #
#########################################################################
-# $Id: Makefile 11184 2011-09-07 14:28:24Z xclerc $
-
include Makefile.shared
# To make custom toplevels
# #
#########################################################################
-# $Id: Makefile.nt 11184 2011-09-07 14:28:24Z xclerc $
-
include Makefile.shared
# To make custom toplevels
# #
#########################################################################
-# $Id: Makefile.shared 12526 2012-05-31 12:41:49Z lefessan $
-
include ../config/Makefile
CAMLRUN=../boot/ocamlrun
CAMLLEX=$(CAMLRUN) ../boot/ocamllex
INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
-I ../driver
-COMPFLAGS= -warn-error A $(INCLUDES)
+COMPFLAGS= -w +32..39 -warn-error A $(INCLUDES)
LINKFLAGS=$(INCLUDES)
all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \
objinfo read_cmt
+
+all: tast_iter.cmo
+
# scrapelabels addlabels
.PHONY: all
-opt.opt: ocamldep.opt
+opt.opt: ocamldep.opt read_cmt.opt
.PHONY: opt.opt
# The dependency generator
CAMLDEP_OBJ=depend.cmo ocamldep.cmo
CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo \
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo \
+ ccomp.cmo pparse.cmo compenv.cmo
ocamldep: depend.cmi $(CAMLDEP_OBJ)
- $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
+ $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx)
$(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \
../parsing/location.cmo \
../parsing/longident.cmo \
../parsing/lexer.cmo \
+ ../parsing/pprintast.cmo \
../typing/ident.cmo \
../typing/path.cmo \
../typing/types.cmo \
../typing/oprint.cmo \
../typing/primitive.cmo \
../typing/printtyp.cmo \
+ ../typing/mtype.cmo \
+ ../typing/envaux.cmo \
+ ../typing/typedtreeMap.cmo \
+ ../typing/typedtreeIter.cmo \
../typing/cmt_format.cmo \
../typing/stypes.cmo \
\
- pprintast.cmo untypeast.cmo typedtreeIter.cmo \
+ untypeast.cmo \
+ tast_iter.cmo \
cmt2annot.cmo read_cmt.cmo
read_cmt: $(READ_CMT)
$(CAMLC) $(LINKFLAGS) -o read_cmt $(READ_CMT)
+read_cmt.opt: $(READ_CMT:.cmo=.cmx)
+ $(CAMLOPT) $(LINKFLAGS) -o read_cmt.opt $(READ_CMT:.cmo=.cmx)
+
clean::
- rm -f read_cmt
+ rm -f read_cmt read_cmt.opt
beforedepend::
(* *)
(***********************************************************************)
-(* $Id: addlabels.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open StdLabels
open Asttypes
open Parsetree
let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in
let pos = insertion_point pos0 ~text in
match arg.pexp_desc with
- | Pexp_ident({ txt = Longident.Lident name }) when l = name && pos = pos0 ->
+ | Pexp_ident({ txt = Longident.Lident name })
+ when l = name && pos = pos0 ->
add_insertion pos "~"
| _ -> add_insertion pos ("~" ^ l ^ ":")
end;
end;
List.iter args ~f:(fun (_,e) -> add_labels_rec e)
| Pexp_apply ({pexp_desc=Pexp_send
- ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},meth)}, args) ->
+ ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},
+ meth)},
+ args) ->
begin try
if SMap.find s values = ["<object>"] then
let labels = SMap.find (s ^ "#" ^ meth) values in
--- /dev/null
+#!/bin/sh
+
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Gallium, INRIA Rocquencourt #
+# #
+# Copyright 2012 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+# check-typo - Check typographic conventions on OCaml sources.
+
+# This program will check files for the following rules:
+
+# - absence of TAB characters (tab)
+# - absence of non-ASCII characters (non-ascii)
+# - absence of non-printing ASCII characters (non-printing)
+# - absence of white space at end of line (white-at-eol)
+# - absence of empty lines at end of file (white-at-eof)
+# - presence of a LF character at the end of the file (missing-lf)
+# - maximum line length of 80 characters (long-line)
+# - presence of a copyright header (missing-header)
+# - absence of a leftover "$Id" string (svn-keyword)
+
+# Exceptions are handled with a SVN property: "ocaml:typo".
+# Its value for a given file is a comma-separated list of rule names,
+# which lists the rules that should be disabled for this file.
+# The rule names are the ones shown above in parentheses.
+
+# Built-in exceptions:
+# - Any binary file (i.e. with svn:mime-type = application/octet-stream)
+# is automatically exempt from all the rules.
+# - Any file whose name begins with "Makefile" is automatically exempt
+# from the "tabs" rule.
+# - Any file whose name matches one of the following patterns is
+# automatically exempt from the "missing-header" rule.
+# */.depend*
+# */.ignore
+# *.mlpack
+# *.mllib
+# *.mltop
+# *.odocl
+# *.clib
+# *.reference
+# */reference
+# - Any file whose name matches one of the following patterns is
+# automatically exempt from the "long-line" rule.
+# *.reference
+
+# ASCII characters are bytes from 0 to 127. Any other byte is
+# flagged as a non-ASCII character.
+
+# For the purpose of this tool, printing ASCII characters are:
+# - the non-white printable ASCII characters (33 to 126)
+# - TAB (09)
+# - LF (10)
+# - SPC (32)
+# Anything else is flagged as a non-printing ASCII character.
+
+# This program will recursively explore the files and directories given
+# on the command line (or by default the current directory), and check
+# every file therein for compliance to the rules.
+
+# Directories named .svn and _build (and their contents) are always ignored.
+# This program ignores any file that is not under svn control, unless
+# explicitly given on the command line.
+
+# If a directory has the SVN property "ocaml:typo" set to "prune",
+# then it and its contents are ignored.
+
+# You can ignore a rule by giving the option -<rule> on the command
+# line (before any file names).
+
+# Special case for recursive call from the find command (see IGNORE_DIRS).
+case "$1" in
+ --check-prune)
+ case `svn propget ocaml:typo "$2" 2>/dev/null` in
+ prune) echo "INFO: pruned directory $2 (ocaml:typo=prune)" >&2; exit 0;;
+ *) exit 3;;
+ esac;;
+esac
+
+usage () {
+ echo "usage: check-typo {-<rule>} [--] {<file-or-dir>}" >&2
+ exit 2
+}
+
+userrules=''
+
+while : ; do
+ case "$1" in
+ -help|--help) usage;;
+ -*) userrules="${1#-},$userrules"; shift;;
+ --) shift; break;;
+ *) break;;
+ esac
+done
+
+IGNORE_DIRS="
+ -name .svn -prune -o
+ -name _build -prune -o
+ -type d -exec $0 --check-prune {} ; -prune -o
+"
+
+( case $# in
+ 0) find . $IGNORE_DIRS -type f -print;;
+ *) for i in "$@"; do find "$i" $IGNORE_DIRS -type f -print; done;;
+ esac
+) | (
+ while read f; do
+ case `svn status "$f" 2>&1` in
+ '?'*) is_svn=false;;
+ I*) is_svn=false;;
+ svn:*"is not a working copy") is_svn=false;;
+ *) is_svn=true;;
+ esac
+ case "$*" in
+ *$f*) is_cmd_line=true;;
+ *) is_cmd_line=false;;
+ esac
+ if $is_svn || $is_cmd_line; then :; else continue; fi
+ svnrules=''
+ if $is_svn; then
+ case `svn propget svn:mime-type "$f"` in
+ application/octet-stream) continue;;
+ esac
+ svnrules=`svn propget ocaml:typo "$f"`
+ fi
+ rules="$userrules"
+ case "$f" in
+ Makefile*|*/Makefile*) rules="tab,$rules";;
+ esac
+ h(){ rules="missing-header,$rules"; }
+ case "$f" in
+ */.depend*|*/.ignore) h;;
+ *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) h;;
+ *.reference|*/reference) h;;
+ esac
+ case "$f" in
+ *.reference) rules="long-line,$rules";;
+ esac
+
+ (cat "$f"; echo) \
+ | awk -v rules="$rules" -v svnrules="$svnrules" -v file="$f" \
+ '
+ function err(name, msg) {
+ ++ counts[name];
+ if (("," rules svnrules ",") !~ ("[, ]" name "[, ]") \
+ && counts[name] <= 10){
+ printf ("%s:%d.%d:", file, NR, RSTART + RLENGTH);
+ printf (" [%s] %s\n", name, msg);
+ if (counts[name] == 10){
+ printf ("WARNING: too many [%s] in this file.", name);
+ printf (" Others will not be reported.\n");
+ }
+ }
+ }
+
+ match($0, /\t/) {
+ err("tab", "TAB character(s)");
+ }
+
+ match($0, /[\200-\377]/) {
+ err("non-ascii", "non-ASCII character(s)");
+ }
+
+ match($0, /[^\t\200-\377 -~]/) {
+ err("non-printing", "non-printing ASCII character(s)");
+ }
+
+ match($0, /[ \t]+$/) {
+ err("white-at-eol", "whitespace at end of line");
+ }
+
+ match($0, /\$Id(: .*)?\$/) {
+ err("svn-keyword", "SVN keyword marker");
+ }
+
+ length($0) > 80 {
+ RSTART = 81;
+ RLENGTH = 0;
+ err("long-line", "line is over 80 characters");
+ }
+
+ 3 <= NR && NR <= 5 \
+ && (/ OCaml / || / ocamlbuild / || / OCamldoc /) {
+ header_ocaml = NR;
+ }
+
+ header_ocaml && header_ocaml + 4 <= NR && NR <= header_ocaml + 6 \
+ && / Copyright / {
+ header_copyright = 1;
+ }
+
+ {
+ prev_line = last_line;
+ last_line = $0;
+ }
+
+ END {
+ if (match(last_line, /.+/)){
+ err("missing-lf", "missing linefeed at EOF");
+ prev_line = last_line;
+ ++ NR;
+ empty_file = 0;
+ }else{
+ empty_file = NR == 1;
+ }
+ if (!empty_file && match(prev_line, /^$/)){
+ err("white-at-eof", "empty line(s) at EOF");
+ }
+ NR = 1;
+ RSTART = 1;
+ RLENGTH = 0;
+ if (!(header_ocaml && header_copyright)){
+ err("missing-header", "missing copyright header");
+ }
+ split(svnrules, r, "[, ]");
+ for (i in r){
+ name = r[i];
+ if (name != "" && !counts[name]){
+ err("unused-prop", sprintf("unused [%s] in ocaml:typo", name));
+ }
+ }
+ }
+ '
+ done
+)
/* */
/***********************************************************************/
-/* $Id: checkstack.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
(***********************************************************************)
(* *)
-(* Objective Caml *)
+(* OCaml *)
(* *)
(* Fabrice Le Fessant, INRIA Saclay *)
(* *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
-(*
-Generate .annot file from a .types files.
-*)
-open Typedtree
-open TypedtreeIter
-
-let pattern_scopes = ref []
-
-let push_None () =
- pattern_scopes := None :: !pattern_scopes
-let push_Some annot =
- pattern_scopes := (Some annot) :: !pattern_scopes
-let pop_scope () =
- match !pattern_scopes with
- [] -> assert false
- | _ :: scopes -> pattern_scopes := scopes
-
-module ForIterator = struct
- open Asttypes
-
- include DefaultIteratorArgument
-
- let structure_begin_scopes = ref []
- let structure_end_scopes = ref []
-
- let rec find_last list =
- match list with
- [] -> assert false
- | [x] -> x
- | _ :: tail -> find_last tail
-
- let enter_structure str =
- match str.str_items with
- [] -> ()
- | _ ->
- let loc =
- match !structure_end_scopes with
- [] -> Location.none
- | _ ->
- let s = find_last str.str_items in
- s.str_loc
- in
- structure_end_scopes := loc :: !structure_end_scopes;
-
- let rec iter list =
- match list with
- [] -> assert false
- | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] ->
- structure_begin_scopes := loc.Location.loc_end
- :: !structure_begin_scopes
- | [ _ ] -> ()
- | item :: tail ->
- iter tail;
- match item, tail with
- { str_desc = Tstr_value (Nonrecursive,_) },
- { str_loc = loc } :: _ ->
- structure_begin_scopes := loc.Location.loc_start
- :: !structure_begin_scopes
- | _ -> ()
- in
- iter str.str_items
-
- let leave_structure str =
- match str.str_items with
- [] -> ()
- | _ ->
- match !structure_end_scopes with
- [] -> assert false
- | _ :: scopes -> structure_end_scopes := scopes
+(* Generate an .annot file from a .cmt file. *)
- let enter_class_expr node =
- Stypes.record (Stypes.Ti_class node)
- let enter_module_expr node =
- Stypes.record (Stypes.Ti_mod node)
+open Asttypes
+open Typedtree
- let add_variable pat id =
- match !pattern_scopes with
- | [] -> assert false
- | None :: _ -> ()
- | (Some s) :: _ ->
- Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s))
+let bind_variables scope =
+ object
+ inherit Tast_iter.iter as super
- let enter_pattern pat =
+ method! pattern pat =
+ super # pattern pat;
match pat.pat_desc with
- | Tpat_var (id, _)
- | Tpat_alias (_, id,_)
- -> add_variable pat id
- | Tpat_any -> ()
- | Tpat_constant _
- | Tpat_tuple _
- | Tpat_construct _
- | Tpat_lazy _
- | Tpat_or _
- | Tpat_array _
- | Tpat_record _
- | Tpat_variant _
- -> ()
-
- let leave_pattern pat =
- Stypes.record (Stypes.Ti_pat pat)
-
- let rec name_of_path = function
- | Path.Pident id -> Ident.name id
- | Path.Pdot(p, s, pos) ->
- if Oprint.parenthesized_ident s then
- name_of_path p ^ ".( " ^ s ^ " )"
- else
- name_of_path p ^ "." ^ s
- | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")"
+ | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
+ Stypes.record (Stypes.An_ident (pat.pat_loc,
+ Ident.name id,
+ Annot.Idef scope))
+ | _ -> ()
+ end
- let enter_expression exp =
- match exp.exp_desc with
- Texp_ident (path, _, _) ->
- let full_name = name_of_path path in
- begin
+let bind_bindings scope bindings =
+ let o = bind_variables scope in
+ List.iter (fun (p, _) -> o # pattern p) bindings
+
+let bind_cases l =
+ List.iter (fun (p, e) -> (bind_variables e.exp_loc) # pattern p) l
+
+let iterator rebuild_env =
+ object(this)
+ val scope = Location.none (* scope of the surrounding structure *)
+
+ inherit Tast_iter.iter as super
+
+ method! class_expr node =
+ Stypes.record (Stypes.Ti_class node);
+ super # class_expr node
+
+ method! module_expr node =
+ Stypes.record (Stypes.Ti_mod node);
+ Tast_iter.module_expr {< scope = node.mod_loc >} node
+
+ method! expression exp =
+ begin match exp.exp_desc with
+ | Texp_ident (path, _, _) ->
+ let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
+ let env =
+ if rebuild_env then
+ try
+ Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
+ with Envaux.Error err ->
+ Format.eprintf "%a@." Envaux.report_error err;
+ exit 2
+ else
+ exp.exp_env
+ in
+ let annot =
try
- let annot = Env.find_annot path exp.exp_env in
- Stypes.record
- (Stypes.An_ident (exp.exp_loc, full_name , annot))
+ let desc = Env.find_value path env in
+ let dloc = desc.Types.val_loc in
+ if dloc.Location.loc_ghost then Annot.Iref_external
+ else Annot.Iref_internal dloc
with Not_found ->
- Stypes.record
- (Stypes.An_ident (exp.exp_loc, full_name , Annot.Iref_external))
- end
-
- | Texp_let (rec_flag, _, body) ->
- begin
- match rec_flag with
- | Recursive -> push_Some (Annot.Idef exp.exp_loc)
- | Nonrecursive -> push_Some (Annot.Idef body.exp_loc)
- | Default -> push_None ()
- end
- | Texp_function _ -> push_None ()
- | Texp_match _ -> push_None ()
- | Texp_try _ -> push_None ()
- | _ -> ()
-
- let leave_expression exp =
- if not exp.exp_loc.Location.loc_ghost then
- Stypes.record (Stypes.Ti_expr exp);
- match exp.exp_desc with
- | Texp_let _
- | Texp_function _
- | Texp_match _
- | Texp_try _
- -> pop_scope ()
- | _ -> ()
-
- let enter_binding pat exp =
- let scope =
- match !pattern_scopes with
- | [] -> assert false
- | None :: _ -> Some (Annot.Idef exp.exp_loc)
- | scope :: _ -> scope
- in
- pattern_scopes := scope :: !pattern_scopes
-
- let leave_binding _ _ =
- pop_scope ()
-
- let enter_class_expr exp =
- match exp.cl_desc with
- | Tcl_fun _ -> push_None ()
- | Tcl_let _ -> push_None ()
- | _ -> ()
-
- let leave_class_expr exp =
- match exp.cl_desc with
- | Tcl_fun _
- | Tcl_let _ -> pop_scope ()
- | _ -> ()
-
- let enter_class_structure _ =
- push_None ()
-
- let leave_class_structure _ =
- pop_scope ()
-
-(*
- let enter_class_field cf =
- match cf.cf_desc with
- Tcf_let _ -> push_None ()
+ Annot.Iref_external
+ in
+ Stypes.record
+ (Stypes.An_ident (exp.exp_loc, full_name , annot))
+ | Texp_let (Recursive, bindings, _) ->
+ bind_bindings exp.exp_loc bindings
+ | Texp_let (Nonrecursive, bindings, body) ->
+ bind_bindings body.exp_loc bindings
+ | Texp_function (_, f, _)
+ | Texp_match (_, f, _)
+ | Texp_try (_, f) ->
+ bind_cases f
| _ -> ()
+ end;
+ Stypes.record (Stypes.Ti_expr exp);
+ super # expression exp
- let leave_class_field cf =
- match cf.cf_desc with
- Tcf_let _ -> pop_scope ()
- | _ -> ()
-*)
+ method! pattern pat =
+ super # pattern pat;
+ Stypes.record (Stypes.Ti_pat pat)
- let enter_structure_item s =
- Stypes.record_phrase s.str_loc;
- match s.str_desc with
- Tstr_value (rec_flag, _) ->
- begin
- let loc = s.str_loc in
- let scope = match !structure_end_scopes with
- [] -> assert false
- | scope :: _ -> scope
- in
- match rec_flag with
- | Recursive -> push_Some
- (Annot.Idef { scope with
- Location.loc_start = loc.Location.loc_start})
- | Nonrecursive ->
-(* TODO: do it lazily, when we start the next element ! *)
-(*
- let start = match srem with
- | [] -> loc.Location.loc_end
- | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
-in *)
- let start =
- match !structure_begin_scopes with
- [] -> assert false
- | loc :: tail ->
- structure_begin_scopes := tail;
- loc
- in
- push_Some (Annot.Idef {scope with Location.loc_start = start})
- | Default -> push_None ()
+ method private structure_item_rem s rem =
+ begin match s with
+ | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} ->
+ let open Location in
+ let doit loc_start = bind_bindings {scope with loc_start} bindings in
+ begin match rec_flag, rem with
+ | Default, _ -> ()
+ | Recursive, _ -> doit loc.loc_start
+ | Nonrecursive, [] -> doit loc.loc_end
+ | Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start
end
- | _ -> ()
-
- let leave_structure_item s =
- match s.str_desc with
- Tstr_value _ -> pop_scope ()
- | _ -> ()
-
+ | _ ->
+ ()
+ end;
+ Stypes.record_phrase s.str_loc;
+ super # structure_item s
+
+ method! structure_item s =
+ (* This will be used for Partial_structure_item.
+ We don't have here the location of the "next" item,
+ this will give a slightly different scope for the non-recursive
+ binding case. *)
+ this # structure_item_rem s []
+
+ method! structure l =
+ let rec loop = function
+ | str :: rem -> this # structure_item_rem str rem; loop rem
+ | [] -> ()
+ in
+ loop l.str_items
+(* TODO: support binding for Tcl_fun, Tcl_let, etc *)
end
-module Iterator = MakeIterator(ForIterator)
-
-let gen_annot target_filename filename cmt =
- match cmt.Cmt_format.cmt_annots with
- Cmt_format.Implementation typedtree ->
- Iterator.iter_structure typedtree;
- let target_filename = match target_filename with
- None -> Some (filename ^ ".annot")
- | Some "-" -> None
- | Some filename -> target_filename
- in
- Stypes.dump target_filename
- | Cmt_format.Interface _ ->
- Printf.fprintf stderr "Cannot generate annotations for interface file\n%!";
+let binary_part iter x =
+ let open Cmt_format in
+ match x with
+ | Partial_structure x -> iter # structure x
+ | Partial_structure_item x -> iter # structure_item x
+ | Partial_expression x -> iter # expression x
+ | Partial_pattern x -> iter # pattern x
+ | Partial_class_expr x -> iter # class_expr x
+ | Partial_signature x -> iter # signature x
+ | Partial_signature_item x -> iter # signature_item x
+ | Partial_module_type x -> iter # module_type x
+
+let gen_annot target_filename filename
+ {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} =
+ let open Cmt_format in
+ Envaux.reset_cache ();
+ Config.load_path := cmt_loadpath;
+ let target_filename =
+ match target_filename with
+ | None -> Some (filename ^ ".annot")
+ | Some "-" -> None
+ | Some filename -> target_filename
+ in
+ let iterator = iterator cmt_use_summaries in
+ match cmt_annots with
+ | Implementation typedtree ->
+ iterator # structure typedtree;
+ Stypes.dump target_filename
+ | Interface _ ->
+ Printf.eprintf "Cannot generate annotations for interface file\n%!";
exit 2
- | _ ->
+ | Partial_implementation parts ->
+ Array.iter (binary_part iterator) parts;
+ Stypes.dump target_filename
+ | _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
let (printer, ext) =
match cmt.Cmt_format.cmt_annots with
| Cmt_format.Implementation typedtree ->
- (fun ppf -> Pprintast.print_structure ppf (Untypeast.untype_structure typedtree)), ".ml"
+ (fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), ".ml"
| Cmt_format.Interface typedtree ->
- (fun ppf -> Pprintast.print_signature ppf (Untypeast.untype_signature typedtree)), ".mli"
+ (fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), ".mli"
| _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
(* *)
(***********************************************************************)
-(* $Id: cvt_emit.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
{
let first_item = ref false
let command_beginning = ref 0
command lexbuf }
| ( [^ '`' '{' '\\'] |
'\\' ['\\' '"' 'n' 't' 'b' 'r' '`' '{' ] |
- '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] ) +
+ '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] |
+ '\\' ('\n' | "\r\n")) +
{ let s = Lexing.lexeme lexbuf in
add_semicolon();
(* Optimise one-character strings *)
(* *)
(***********************************************************************)
-(* $Id: depend.ml 12883 2012-08-25 11:35:20Z garrigue $ *)
-
open Asttypes
-open Format
open Location
open Longident
open Parsetree
(* Collect free module identifiers in the a.s.t. *)
-let fst3 (x, _, _) = x
-
let free_structure_names = ref StringSet.empty
let rec addmodule bv lid =
(fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
td.ptype_cstrs;
add_opt add_type bv td.ptype_manifest;
- let rec add_tkind = function
+ let add_tkind = function
Ptype_abstract -> ()
| Ptype_variant cstrs ->
- List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs
+ List.iter (fun (c, args, rty, _) ->
+ List.iter (add_type bv) args;
+ Misc.may (add_type bv) rty)
+ cstrs
| Ptype_record lbls ->
List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
add_tkind td.ptype_kind
let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
| Pexp_newtype (_, e) -> add_expr bv e
| Pexp_pack m -> add_module bv m
- | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
+ | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e
and add_pat_expr_list bv pel =
List.iter (fun (p, e) -> let bv = add_pattern bv p in add_expr bv e) pel
| Psig_module(id, mty) ->
add_modtype bv mty; StringSet.add id.txt bv
| Psig_recmodule decls ->
- let bv' = List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv in
+ let bv' =
+ List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv
+ in
List.iter (fun (id, mty) -> add_modtype bv' mty) decls;
bv'
| Psig_modtype(id,mtyd) ->
| Pmodtype_manifest mty -> add_modtype bv mty
end;
bv
- | Psig_open lid ->
+ | Psig_open (_ovf, lid) ->
addmodule bv lid; bv
| Psig_include mty ->
add_modtype bv mty; bv
bv'
| Pstr_modtype(id, mty) ->
add_modtype bv mty; bv
- | Pstr_open l ->
+ | Pstr_open (_ovf, l) ->
addmodule bv l; bv
| Pstr_class cdl ->
List.iter (add_class_declaration bv) cdl; bv
and add_use_file bv top_phrs =
ignore (List.fold_left add_top_phrase bv top_phrs)
+and add_implementation bv l =
+ ignore (add_structure bv l)
+
and add_top_phrase bv = function
| Ptop_def str -> add_structure bv str
| Ptop_dir (_, _) -> bv
(* *)
(***********************************************************************)
-(* $Id: depend.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(** Module dependencies. *)
module StringSet : Set.S with type elt = string
val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit
val add_signature : StringSet.t -> Parsetree.signature -> unit
+
+val add_implementation : StringSet.t -> Parsetree.structure -> unit
(* *)
(***********************************************************************)
-(* $Id: dumpobj.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Disassembler for executable and .cmo object files *)
open Asttypes
open Config
-open Emitcode
open Instruct
open Lambda
open Location
-open Obj
open Opcodes
open Opnames
open Cmo_format
let nvars = inputu ic in
let orig = currpc ic in
print_int nvars;
- for i = 0 to nfuncs - 1 do
+ for _i = 0 to nfuncs - 1 do
print_string ", ";
print_int (orig + inputs ic);
done;
begin try
ignore (Bytesections.seek_section ic "DBUG");
let num_eventlists = input_binary_int ic in
- for i = 1 to num_eventlists do
+ for _i = 1 to num_eventlists do
let orig = input_binary_int ic in
let evl = (input_value ic : debug_event list) in
record_events orig evl
let arg_list = [
"-noloc", Arg.Clear print_locations, " : don't print source information";
]
-let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files" Sys.argv.(0)
+let arg_usage =
+ Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files"
+ Sys.argv.(0)
let first_file = ref true
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Hongbo Zhang (University of Pennsylvania) *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(**************************************************************************)
+
+
+(*
+ This module is mainly used to diff two parsetree, it helps to automate the
+ test for parsing/pprintast.ml
+ *)
+
+
+open Parsetree
+let curry f (g, h) = f g h
+let eq_int : (int*int)->bool = curry (=)
+let eq_char : (char*char)->bool=curry (=)
+let eq_string : (string*string)->bool = curry (=)
+let eq_int32 : (int32*int32)->bool=curry (=)
+let eq_int64 : (int64*int64)->bool =curry (=)
+let eq_nativeint : (nativeint*nativeint)->bool= curry (=)
+let eq_bool :(bool*bool) -> bool = curry (=)
+let eq_list mf_a (xs, ys) =
+ let rec loop =
+ function
+ | ([], []) -> true
+ | (x :: xs, y :: ys) -> (mf_a (x, y)) && (loop (xs, ys))
+ | (_, _) -> false
+ in loop (xs, ys)
+let eq_option mf_a (x, y) =
+ match (x, y) with
+ | (None, None) -> true
+ | (Some x, Some y) -> mf_a (x, y)
+ | (_, _) -> false
+
+module Location =struct
+ include Location
+ let eq_t : (t*t) -> bool = fun (_,_) -> true
+end
+module Longident = struct
+ include Longident
+ let rec eq_t : (t * t) -> 'result =
+ function
+ | (Lident a0, Lident b0) -> eq_string (a0, b0)
+ | (Ldot (a0, a1), Ldot (b0, b1)) ->
+ (eq_t (a0, b0)) && (eq_string (a1, b1))
+ | (Lapply (a0, a1), Lapply (b0, b1)) ->
+ (eq_t (a0, b0)) && (eq_t (a1, b1))
+ | (_, _) -> false
+end
+module Asttypes = struct
+ open Asttypes
+ let eq_constant : (constant * constant) -> 'result =
+ function
+ | (Const_int a0, Const_int b0) -> eq_int (a0, b0)
+ | (Const_char a0, Const_char b0) -> eq_char (a0, b0)
+ | (Const_string a0, Const_string b0) -> eq_string (a0, b0)
+ | (Const_float a0, Const_float b0) -> eq_string (a0, b0)
+ | (Const_int32 a0, Const_int32 b0) -> eq_int32 (a0, b0)
+ | (Const_int64 a0, Const_int64 b0) -> eq_int64 (a0, b0)
+ | (Const_nativeint a0, Const_nativeint b0) -> eq_nativeint (a0, b0)
+ | (_, _) -> false
+
+ let eq_rec_flag : (rec_flag * rec_flag) -> 'result =
+ function
+ | (Nonrecursive, Nonrecursive) -> true
+ | (Recursive, Recursive) -> true
+ | (Default, Default) -> true
+ | (_, _) -> false
+
+ let eq_direction_flag :
+ (direction_flag * direction_flag) -> 'result =
+ function
+ | (Upto, Upto) -> true
+ | (Downto, Downto) -> true
+ | (_, _) -> false
+
+ let eq_private_flag : (private_flag * private_flag) -> 'result =
+ function
+ | (Private, Private) -> true
+ | (Public, Public) -> true
+ | (_, _) -> false
+
+ let eq_mutable_flag : (mutable_flag * mutable_flag) -> 'result =
+ function
+ | (Immutable, Immutable) -> true
+ | (Mutable, Mutable) -> true
+ | (_, _) -> false
+
+ let eq_virtual_flag : (virtual_flag * virtual_flag) -> 'result =
+ function
+ | (Virtual, Virtual) -> true
+ | (Concrete, Concrete) -> true
+ | (_, _) -> false
+
+ let eq_override_flag : (override_flag * override_flag) -> 'result =
+ function
+ | (Override, Override) -> true
+ | (Fresh, Fresh) -> true
+ | (_, _) -> false
+
+ let eq_closed_flag : (closed_flag * closed_flag) -> 'result =
+ function
+ | (Closed, Closed) -> true
+ | (Open, Open) -> true
+ | (_, _) -> false
+
+ let eq_label : (label * label) -> 'result =
+ fun (a0, a1) -> eq_string (a0, a1)
+
+ let eq_loc :
+ 'all_a0.
+ (('all_a0 * 'all_a0) -> 'result) ->
+ (('all_a0 loc) * ('all_a0 loc)) -> 'result =
+ fun mf_a ({ txt = a0; loc = a1 }, { txt = b0; loc = b1 }) ->
+ (mf_a (a0, b0)) && (Location.eq_t (a1, b1))
+
+end
+
+let rec eq_row_field : (row_field * row_field) -> 'result =
+ function
+ | (Rtag (a0, a1, a2), Rtag (b0, b1, b2)) ->
+ ((Asttypes.eq_label (a0, b0)) && (eq_bool (a1, b1))) &&
+ (eq_list eq_core_type (a2, b2))
+ | (Rinherit a0, Rinherit b0) -> eq_core_type (a0, b0)
+ | (_, _) -> false
+and eq_core_field_desc :
+ (core_field_desc * core_field_desc) -> 'result =
+ function
+ | (Pfield (a0, a1), Pfield (b0, b1)) ->
+ (eq_string (a0, b0)) && (eq_core_type (a1, b1))
+ | (Pfield_var, Pfield_var) -> true
+ | (_, _) -> false
+and eq_core_field_type :
+ (core_field_type * core_field_type) -> 'result =
+ fun
+ ({ pfield_desc = a0; pfield_loc = a1 },
+ { pfield_desc = b0; pfield_loc = b1 })
+ -> (eq_core_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_package_type : (package_type * package_type) -> 'result =
+ fun (a0, a1) ->
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_core_type (a1, b1)))
+ (a1, b1)))
+ (a0, a1)
+and eq_core_type_desc :
+ (core_type_desc * core_type_desc) -> 'result =
+ function
+ | (Ptyp_any, Ptyp_any) -> true
+ | (Ptyp_var a0, Ptyp_var b0) -> eq_string (a0, b0)
+ | (Ptyp_arrow (a0, a1, a2), Ptyp_arrow (b0, b1, b2)) ->
+ ((Asttypes.eq_label (a0, b0)) && (eq_core_type (a1, b1))) &&
+ (eq_core_type (a2, b2))
+ | (Ptyp_tuple a0, Ptyp_tuple b0) -> eq_list eq_core_type (a0, b0)
+ | (Ptyp_constr (a0, a1), Ptyp_constr (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_list eq_core_type (a1, b1))
+ | (Ptyp_object a0, Ptyp_object b0) ->
+ eq_list eq_core_field_type (a0, b0)
+ | (Ptyp_class (a0, a1, a2), Ptyp_class (b0, b1, b2)) ->
+ ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_list eq_core_type (a1, b1)))
+ && (eq_list Asttypes.eq_label (a2, b2))
+ | (Ptyp_alias (a0, a1), Ptyp_alias (b0, b1)) ->
+ (eq_core_type (a0, b0)) && (eq_string (a1, b1))
+ | (Ptyp_variant (a0, a1, a2), Ptyp_variant (b0, b1, b2)) ->
+ ((eq_list eq_row_field (a0, b0)) && (eq_bool (a1, b1))) &&
+ (eq_option (eq_list Asttypes.eq_label) (a2, b2))
+ | (Ptyp_poly (a0, a1), Ptyp_poly (b0, b1)) ->
+ (eq_list eq_string (a0, b0)) && (eq_core_type (a1, b1))
+ | (Ptyp_package a0, Ptyp_package b0) -> eq_package_type (a0, b0)
+ | (_, _) -> false
+and eq_core_type : (core_type * core_type) -> 'result =
+ fun
+ ({ ptyp_desc = a0; ptyp_loc = a1 },
+ { ptyp_desc = b0; ptyp_loc = b1 })
+ -> (eq_core_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
+let eq_class_infos :
+ 'all_a0.
+ (('all_a0 * 'all_a0) -> 'result) ->
+ (('all_a0 class_infos) * ('all_a0 class_infos)) -> 'result =
+ fun mf_a
+ ({
+ pci_virt = a0;
+ pci_params = a1;
+ pci_name = a2;
+ pci_expr = a3;
+ pci_variance = a4;
+ pci_loc = a5
+ },
+ {
+ pci_virt = b0;
+ pci_params = b1;
+ pci_name = b2;
+ pci_expr = b3;
+ pci_variance = b4;
+ pci_loc = b5
+ })
+ ->
+ (((((Asttypes.eq_virtual_flag (a0, b0)) &&
+ ((fun ((a0, a1), (b0, b1)) ->
+ (eq_list (Asttypes.eq_loc eq_string) (a0, b0)) &&
+ (Location.eq_t (a1, b1)))
+ (a1, b1)))
+ && (Asttypes.eq_loc eq_string (a2, b2)))
+ && (mf_a (a3, b3)))
+ &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_bool (a0, b0)) && (eq_bool (a1, b1)))
+ (a4, b4)))
+ && (Location.eq_t (a5, b5))
+
+let rec eq_pattern_desc : (pattern_desc * pattern_desc) -> 'result =
+ function
+ | (Ppat_any, Ppat_any) -> true
+ | (Ppat_var a0, Ppat_var b0) -> Asttypes.eq_loc eq_string (a0, b0)
+ | (Ppat_alias (a0, a1), Ppat_alias (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (Asttypes.eq_loc eq_string (a1, b1))
+ | (Ppat_constant a0, Ppat_constant b0) ->
+ Asttypes.eq_constant (a0, b0)
+ | (Ppat_tuple a0, Ppat_tuple b0) -> eq_list eq_pattern (a0, b0)
+ | (Ppat_construct (a0, a1, a2), Ppat_construct (b0, b1, b2)) ->
+ ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_option eq_pattern (a1, b1)))
+ && (eq_bool (a2, b2))
+ | (Ppat_variant (a0, a1), Ppat_variant (b0, b1)) ->
+ (Asttypes.eq_label (a0, b0)) && (eq_option eq_pattern (a1, b1))
+ | (Ppat_record (a0, a1), Ppat_record (b0, b1)) ->
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_pattern (a1, b1)))
+ (a0, b0))
+ && (Asttypes.eq_closed_flag (a1, b1))
+ | (Ppat_array a0, Ppat_array b0) -> eq_list eq_pattern (a0, b0)
+ | (Ppat_or (a0, a1), Ppat_or (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_pattern (a1, b1))
+ | (Ppat_constraint (a0, a1), Ppat_constraint (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_core_type (a1, b1))
+ | (Ppat_type a0, Ppat_type b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Ppat_lazy a0, Ppat_lazy b0) -> eq_pattern (a0, b0)
+ | (Ppat_unpack a0, Ppat_unpack b0) ->
+ Asttypes.eq_loc eq_string (a0, b0)
+ | (_, _) -> false
+and eq_pattern : (pattern * pattern) -> 'result =
+ fun
+ ({ ppat_desc = a0; ppat_loc = a1 },
+ { ppat_desc = b0; ppat_loc = b1 })
+ -> (eq_pattern_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
+let rec eq_structure_item_desc :
+ (structure_item_desc * structure_item_desc) -> 'result =
+ function
+ | (Pstr_eval a0, Pstr_eval b0) -> eq_expression (a0, b0)
+ | (Pstr_value (a0, a1), Pstr_value (b0, b1)) ->
+ (Asttypes.eq_rec_flag (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+ (a1, b1))
+ | (Pstr_primitive (a0, a1), Pstr_primitive (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_value_description (a1, b1))
+ | (Pstr_type a0, Pstr_type b0) ->
+ eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_type_declaration (a1, b1)))
+ (a0, b0)
+ | (Pstr_exception (a0, a1), Pstr_exception (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_exception_declaration (a1, b1))
+ | (Pstr_exn_rebind (a0, a1), Pstr_exn_rebind (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (Asttypes.eq_loc Longident.eq_t (a1, b1))
+ | (Pstr_module (a0, a1), Pstr_module (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_expr (a1, b1))
+ | (Pstr_recmodule a0, Pstr_recmodule b0) ->
+ eq_list
+ (fun ((a0, a1, a2), (b0, b1, b2)) ->
+ ((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_type (a1, b1)))
+ && (eq_module_expr (a2, b2)))
+ (a0, b0)
+ | (Pstr_modtype (a0, a1), Pstr_modtype (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_type (a1, b1))
+ | (Pstr_open a0, Pstr_open b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Pstr_class a0, Pstr_class b0) ->
+ eq_list eq_class_declaration (a0, b0)
+ | (Pstr_class_type a0, Pstr_class_type b0) ->
+ eq_list eq_class_type_declaration (a0, b0)
+ | (Pstr_include a0, Pstr_include b0) -> eq_module_expr (a0, b0)
+ | (_, _) -> false
+and eq_structure_item :
+ (structure_item * structure_item) -> 'result =
+ fun
+ ({ pstr_desc = a0; pstr_loc = a1 },
+ { pstr_desc = b0; pstr_loc = b1 })
+ -> (eq_structure_item_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_structure : (structure * structure) -> 'result =
+ fun (a0, a1) -> eq_list eq_structure_item (a0, a1)
+and eq_module_expr_desc :
+ (module_expr_desc * module_expr_desc) -> 'result =
+ function
+ | (Pmod_ident a0, Pmod_ident b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Pmod_structure a0, Pmod_structure b0) -> eq_structure (a0, b0)
+ | (Pmod_functor (a0, a1, a2), Pmod_functor (b0, b1, b2)) ->
+ ((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_type (a1, b1)))
+ && (eq_module_expr (a2, b2))
+ | (Pmod_apply (a0, a1), Pmod_apply (b0, b1)) ->
+ (eq_module_expr (a0, b0)) && (eq_module_expr (a1, b1))
+ | (Pmod_constraint (a0, a1), Pmod_constraint (b0, b1)) ->
+ (eq_module_expr (a0, b0)) && (eq_module_type (a1, b1))
+ | (Pmod_unpack a0, Pmod_unpack b0) -> eq_expression (a0, b0)
+ | (_, _) -> false
+and eq_module_expr : (module_expr * module_expr) -> 'result =
+ fun
+ ({ pmod_desc = a0; pmod_loc = a1 },
+ { pmod_desc = b0; pmod_loc = b1 })
+ -> (eq_module_expr_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_with_constraint :
+ (with_constraint * with_constraint) -> 'result =
+ function
+ | (Pwith_type a0, Pwith_type b0) -> eq_type_declaration (a0, b0)
+ | (Pwith_module a0, Pwith_module b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Pwith_typesubst a0, Pwith_typesubst b0) ->
+ eq_type_declaration (a0, b0)
+ | (Pwith_modsubst a0, Pwith_modsubst b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (_, _) -> false
+and eq_modtype_declaration :
+ (modtype_declaration * modtype_declaration) -> 'result =
+ function
+ | (Pmodtype_abstract, Pmodtype_abstract) -> true
+ | (Pmodtype_manifest a0, Pmodtype_manifest b0) ->
+ eq_module_type (a0, b0)
+ | (_, _) -> false
+and eq_signature_item_desc :
+ (signature_item_desc * signature_item_desc) -> 'result =
+ function
+ | (Psig_value (a0, a1), Psig_value (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_value_description (a1, b1))
+ | (Psig_type a0, Psig_type b0) ->
+ eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_type_declaration (a1, b1)))
+ (a0, b0)
+ | (Psig_exception (a0, a1), Psig_exception (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_exception_declaration (a1, b1))
+ | (Psig_module (a0, a1), Psig_module (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_type (a1, b1))
+ | (Psig_recmodule a0, Psig_recmodule b0) ->
+ eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_type (a1, b1)))
+ (a0, b0)
+ | (Psig_modtype (a0, a1), Psig_modtype (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_modtype_declaration (a1, b1))
+ | (Psig_open a0, Psig_open b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Psig_include a0, Psig_include b0) -> eq_module_type (a0, b0)
+ | (Psig_class a0, Psig_class b0) ->
+ eq_list eq_class_description (a0, b0)
+ | (Psig_class_type a0, Psig_class_type b0) ->
+ eq_list eq_class_type_declaration (a0, b0)
+ | (_, _) -> false
+and eq_signature_item :
+ (signature_item * signature_item) -> 'result =
+ fun
+ ({ psig_desc = a0; psig_loc = a1 },
+ { psig_desc = b0; psig_loc = b1 })
+ -> (eq_signature_item_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_signature : (signature * signature) -> 'result =
+ fun (a0, a1) -> eq_list eq_signature_item (a0, a1)
+and eq_module_type_desc :
+ (module_type_desc * module_type_desc) -> 'result =
+ function
+ | (Pmty_ident a0, Pmty_ident b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Pmty_signature a0, Pmty_signature b0) -> eq_signature (a0, b0)
+ | (Pmty_functor (a0, a1, a2), Pmty_functor (b0, b1, b2)) ->
+ ((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_type (a1, b1)))
+ && (eq_module_type (a2, b2))
+ | (Pmty_with (a0, a1), Pmty_with (b0, b1)) ->
+ (eq_module_type (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_with_constraint (a1, b1)))
+ (a1, b1))
+ | (Pmty_typeof a0, Pmty_typeof b0) -> eq_module_expr (a0, b0)
+ | (_, _) -> false
+and eq_module_type : (module_type * module_type) -> 'result =
+ fun
+ ({ pmty_desc = a0; pmty_loc = a1 },
+ { pmty_desc = b0; pmty_loc = b1 })
+ -> (eq_module_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_declaration :
+ (class_declaration * class_declaration) -> 'result =
+ fun (a0, a1) -> eq_class_infos eq_class_expr (a0, a1)
+and eq_class_field_desc :
+ (class_field_desc * class_field_desc) -> 'result =
+ function
+ | (Pcf_inher (a0, a1, a2), Pcf_inher (b0, b1, b2)) ->
+ ((Asttypes.eq_override_flag (a0, b0)) &&
+ (eq_class_expr (a1, b1)))
+ && (eq_option eq_string (a2, b2))
+ | (Pcf_valvirt a0, Pcf_valvirt b0) ->
+ (fun ((a0, a1, a2), (b0, b1, b2)) ->
+ ((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (Asttypes.eq_mutable_flag (a1, b1)))
+ && (eq_core_type (a2, b2)))
+ (a0, b0)
+ | (Pcf_val a0, Pcf_val b0) ->
+ (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+ (((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (Asttypes.eq_mutable_flag (a1, b1)))
+ && (Asttypes.eq_override_flag (a2, b2)))
+ && (eq_expression (a3, b3)))
+ (a0, b0)
+ | (Pcf_virt a0, Pcf_virt b0) ->
+ (fun ((a0, a1, a2), (b0, b1, b2)) ->
+ ((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (Asttypes.eq_private_flag (a1, b1)))
+ && (eq_core_type (a2, b2)))
+ (a0, b0)
+ | (Pcf_meth a0, Pcf_meth b0) ->
+ (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+ (((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (Asttypes.eq_private_flag (a1, b1)))
+ && (Asttypes.eq_override_flag (a2, b2)))
+ && (eq_expression (a3, b3)))
+ (a0, b0)
+ | (Pcf_constr a0, Pcf_constr b0) ->
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+ (a0, b0)
+ | (Pcf_init a0, Pcf_init b0) -> eq_expression (a0, b0)
+ | (_, _) -> false
+and eq_class_field : (class_field * class_field) -> 'result =
+ fun
+ ({ pcf_desc = a0; pcf_loc = a1 }, { pcf_desc = b0; pcf_loc = b1
+ })
+ -> (eq_class_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_structure :
+ (class_structure * class_structure) -> 'result =
+ fun
+ ({ pcstr_pat = a0; pcstr_fields = a1 },
+ { pcstr_pat = b0; pcstr_fields = b1 })
+ -> (eq_pattern (a0, b0)) && (eq_list eq_class_field (a1, b1))
+and eq_class_expr_desc :
+ (class_expr_desc * class_expr_desc) -> 'result =
+ function
+ | (Pcl_constr (a0, a1), Pcl_constr (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_list eq_core_type (a1, b1))
+ | (Pcl_structure a0, Pcl_structure b0) ->
+ eq_class_structure (a0, b0)
+ | (Pcl_fun (a0, a1, a2, a3), Pcl_fun (b0, b1, b2, b3)) ->
+ (((Asttypes.eq_label (a0, b0)) &&
+ (eq_option eq_expression (a1, b1)))
+ && (eq_pattern (a2, b2)))
+ && (eq_class_expr (a3, b3))
+ | (Pcl_apply (a0, a1), Pcl_apply (b0, b1)) ->
+ (eq_class_expr (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_label (a0, b0)) &&
+ (eq_expression (a1, b1)))
+ (a1, b1))
+ | (Pcl_let (a0, a1, a2), Pcl_let (b0, b1, b2)) ->
+ ((Asttypes.eq_rec_flag (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+ (a1, b1)))
+ && (eq_class_expr (a2, b2))
+ | (Pcl_constraint (a0, a1), Pcl_constraint (b0, b1)) ->
+ (eq_class_expr (a0, b0)) && (eq_class_type (a1, b1))
+ | (_, _) -> false
+and eq_class_expr : (class_expr * class_expr) -> 'result =
+ fun
+ ({ pcl_desc = a0; pcl_loc = a1 }, { pcl_desc = b0; pcl_loc = b1
+ })
+ -> (eq_class_expr_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_type_declaration :
+ (class_type_declaration * class_type_declaration) -> 'result =
+ fun (a0, a1) -> eq_class_infos eq_class_type (a0, a1)
+and eq_class_description :
+ (class_description * class_description) -> 'result =
+ fun (a0, a1) -> eq_class_infos eq_class_type (a0, a1)
+and eq_class_type_field_desc :
+ (class_type_field_desc * class_type_field_desc) -> 'result =
+ function
+ | (Pctf_inher a0, Pctf_inher b0) -> eq_class_type (a0, b0)
+ | (Pctf_val a0, Pctf_val b0) ->
+ (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+ (((eq_string (a0, b0)) &&
+ (Asttypes.eq_mutable_flag (a1, b1)))
+ && (Asttypes.eq_virtual_flag (a2, b2)))
+ && (eq_core_type (a3, b3)))
+ (a0, b0)
+ | (Pctf_virt a0, Pctf_virt b0) ->
+ (fun ((a0, a1, a2), (b0, b1, b2)) ->
+ ((eq_string (a0, b0)) && (Asttypes.eq_private_flag (a1, b1)))
+ && (eq_core_type (a2, b2)))
+ (a0, b0)
+ | (Pctf_meth a0, Pctf_meth b0) ->
+ (fun ((a0, a1, a2), (b0, b1, b2)) ->
+ ((eq_string (a0, b0)) && (Asttypes.eq_private_flag (a1, b1)))
+ && (eq_core_type (a2, b2)))
+ (a0, b0)
+ | (Pctf_cstr a0, Pctf_cstr b0) ->
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+ (a0, b0)
+ | (_, _) -> false
+and eq_class_type_field :
+ (class_type_field * class_type_field) -> 'result =
+ fun
+ ({ pctf_desc = a0; pctf_loc = a1 },
+ { pctf_desc = b0; pctf_loc = b1 })
+ ->
+ (eq_class_type_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_signature :
+ (class_signature * class_signature) -> 'result =
+ fun
+ ({ pcsig_self = a0; pcsig_fields = a1; pcsig_loc = a2 },
+ { pcsig_self = b0; pcsig_fields = b1; pcsig_loc = b2 })
+ ->
+ ((eq_core_type (a0, b0)) &&
+ (eq_list eq_class_type_field (a1, b1)))
+ && (Location.eq_t (a2, b2))
+and eq_class_type_desc :
+ (class_type_desc * class_type_desc) -> 'result =
+ function
+ | (Pcty_constr (a0, a1), Pcty_constr (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_list eq_core_type (a1, b1))
+ | (Pcty_signature a0, Pcty_signature b0) ->
+ eq_class_signature (a0, b0)
+ | (Pcty_fun (a0, a1, a2), Pcty_fun (b0, b1, b2)) ->
+ ((Asttypes.eq_label (a0, b0)) && (eq_core_type (a1, b1))) &&
+ (eq_class_type (a2, b2))
+ | (_, _) -> false
+and eq_class_type : (class_type * class_type) -> 'result =
+ fun
+ ({ pcty_desc = a0; pcty_loc = a1 },
+ { pcty_desc = b0; pcty_loc = b1 })
+ -> (eq_class_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_exception_declaration :
+ (exception_declaration * exception_declaration) -> 'result =
+ fun (a0, a1) -> eq_list eq_core_type (a0, a1)
+and eq_type_kind : (type_kind * type_kind) -> 'result =
+ function
+ | (Ptype_abstract, Ptype_abstract) -> true
+ | (Ptype_variant a0, Ptype_variant b0) ->
+ eq_list
+ (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+ (((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_list eq_core_type (a1, b1)))
+ && (eq_option eq_core_type (a2, b2)))
+ && (Location.eq_t (a3, b3)))
+ (a0, b0)
+ | (Ptype_record a0, Ptype_record b0) ->
+ eq_list
+ (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+ (((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (Asttypes.eq_mutable_flag (a1, b1)))
+ && (eq_core_type (a2, b2)))
+ && (Location.eq_t (a3, b3)))
+ (a0, b0)
+ | (_, _) -> false
+and eq_type_declaration :
+ (type_declaration * type_declaration) -> 'result =
+ fun
+ ({
+ ptype_params = a0;
+ ptype_cstrs = a1;
+ ptype_kind = a2;
+ ptype_private = a3;
+ ptype_manifest = a4;
+ ptype_variance = a5;
+ ptype_loc = a6
+ },
+ {
+ ptype_params = b0;
+ ptype_cstrs = b1;
+ ptype_kind = b2;
+ ptype_private = b3;
+ ptype_manifest = b4;
+ ptype_variance = b5;
+ ptype_loc = b6
+ })
+ ->
+ ((((((eq_list (eq_option (Asttypes.eq_loc eq_string)) (a0, b0))
+ &&
+ (eq_list
+ (fun ((a0, a1, a2), (b0, b1, b2)) ->
+ ((eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+ && (Location.eq_t (a2, b2)))
+ (a1, b1)))
+ && (eq_type_kind (a2, b2)))
+ && (Asttypes.eq_private_flag (a3, b3)))
+ && (eq_option eq_core_type (a4, b4)))
+ &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_bool (a0, b0)) && (eq_bool (a1, b1)))
+ (a5, b5)))
+ && (Location.eq_t (a6, b6))
+and eq_value_description :
+ (value_description * value_description) -> 'result =
+ fun
+ ({ pval_type = a0; pval_prim = a1; pval_loc = a2 },
+ { pval_type = b0; pval_prim = b1; pval_loc = b2 })
+ ->
+ ((eq_core_type (a0, b0)) && (eq_list eq_string (a1, b1))) &&
+ (Location.eq_t (a2, b2))
+and eq_expression_desc :
+ (expression_desc * expression_desc) -> 'result =
+ function
+ | (Pexp_ident a0, Pexp_ident b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Pexp_constant a0, Pexp_constant b0) ->
+ Asttypes.eq_constant (a0, b0)
+ | (Pexp_let (a0, a1, a2), Pexp_let (b0, b1, b2)) ->
+ ((Asttypes.eq_rec_flag (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+ (a1, b1)))
+ && (eq_expression (a2, b2))
+ | (Pexp_function (a0, a1, a2), Pexp_function (b0, b1, b2)) ->
+ ((Asttypes.eq_label (a0, b0)) &&
+ (eq_option eq_expression (a1, b1)))
+ &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+ (a2, b2))
+ | (Pexp_apply (a0, a1), Pexp_apply (b0, b1)) ->
+ (eq_expression (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_label (a0, b0)) &&
+ (eq_expression (a1, b1)))
+ (a1, b1))
+ | (Pexp_match (a0, a1), Pexp_match (b0, b1)) ->
+ (eq_expression (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+ (a1, b1))
+ | (Pexp_try (a0, a1), Pexp_try (b0, b1)) ->
+ (eq_expression (a0, b0)) &&
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+ (a1, b1))
+ | (Pexp_tuple a0, Pexp_tuple b0) -> eq_list eq_expression (a0, b0)
+ | (Pexp_construct (a0, a1, a2), Pexp_construct (b0, b1, b2)) ->
+ ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_option eq_expression (a1, b1)))
+ && (eq_bool (a2, b2))
+ | (Pexp_variant (a0, a1), Pexp_variant (b0, b1)) ->
+ (Asttypes.eq_label (a0, b0)) &&
+ (eq_option eq_expression (a1, b1))
+ | (Pexp_record (a0, a1), Pexp_record (b0, b1)) ->
+ (eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_expression (a1, b1)))
+ (a0, b0))
+ && (eq_option eq_expression (a1, b1))
+ | (Pexp_field (a0, a1), Pexp_field (b0, b1)) ->
+ (eq_expression (a0, b0)) &&
+ (Asttypes.eq_loc Longident.eq_t (a1, b1))
+ | (Pexp_setfield (a0, a1, a2), Pexp_setfield (b0, b1, b2)) ->
+ ((eq_expression (a0, b0)) &&
+ (Asttypes.eq_loc Longident.eq_t (a1, b1)))
+ && (eq_expression (a2, b2))
+ | (Pexp_array a0, Pexp_array b0) -> eq_list eq_expression (a0, b0)
+ | (Pexp_ifthenelse (a0, a1, a2), Pexp_ifthenelse (b0, b1, b2)) ->
+ ((eq_expression (a0, b0)) && (eq_expression (a1, b1))) &&
+ (eq_option eq_expression (a2, b2))
+ | (Pexp_sequence (a0, a1), Pexp_sequence (b0, b1)) ->
+ (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+ | (Pexp_while (a0, a1), Pexp_while (b0, b1)) ->
+ (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+ | (Pexp_for (a0, a1, a2, a3, a4), Pexp_for (b0, b1, b2, b3, b4)) ->
+ ((((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_expression (a1, b1)))
+ && (eq_expression (a2, b2)))
+ && (Asttypes.eq_direction_flag (a3, b3)))
+ && (eq_expression (a4, b4))
+ | (Pexp_constraint (a0, a1, a2), Pexp_constraint (b0, b1, b2)) ->
+ ((eq_expression (a0, b0)) && (eq_option eq_core_type (a1, b1)))
+ && (eq_option eq_core_type (a2, b2))
+ | (Pexp_when (a0, a1), Pexp_when (b0, b1)) ->
+ (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+ | (Pexp_send (a0, a1), Pexp_send (b0, b1)) ->
+ (eq_expression (a0, b0)) && (eq_string (a1, b1))
+ | (Pexp_new a0, Pexp_new b0) ->
+ Asttypes.eq_loc Longident.eq_t (a0, b0)
+ | (Pexp_setinstvar (a0, a1), Pexp_setinstvar (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_expression (a1, b1))
+ | (Pexp_override a0, Pexp_override b0) ->
+ eq_list
+ (fun ((a0, a1), (b0, b1)) ->
+ (Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_expression (a1, b1)))
+ (a0, b0)
+ | (Pexp_letmodule (a0, a1, a2), Pexp_letmodule (b0, b1, b2)) ->
+ ((Asttypes.eq_loc eq_string (a0, b0)) &&
+ (eq_module_expr (a1, b1)))
+ && (eq_expression (a2, b2))
+ | (Pexp_assert a0, Pexp_assert b0) -> eq_expression (a0, b0)
+ | (Pexp_assertfalse, Pexp_assertfalse) -> true
+ | (Pexp_lazy a0, Pexp_lazy b0) -> eq_expression (a0, b0)
+ | (Pexp_poly (a0, a1), Pexp_poly (b0, b1)) ->
+ (eq_expression (a0, b0)) && (eq_option eq_core_type (a1, b1))
+ | (Pexp_object a0, Pexp_object b0) -> eq_class_structure (a0, b0)
+ | (Pexp_newtype (a0, a1), Pexp_newtype (b0, b1)) ->
+ (eq_string (a0, b0)) && (eq_expression (a1, b1))
+ | (Pexp_pack a0, Pexp_pack b0) -> eq_module_expr (a0, b0)
+ | (Pexp_open (a0, a1), Pexp_open (b0, b1)) ->
+ (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+ (eq_expression (a1, b1))
+ | (_, _) -> false
+and eq_expression : (expression * expression) -> 'result =
+ fun
+ ({ pexp_desc = a0; pexp_loc = a1 },
+ { pexp_desc = b0; pexp_loc = b1 })
+ -> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
+let rec eq_directive_argument :
+ (directive_argument * directive_argument) -> 'result =
+ function
+ | (Pdir_none, Pdir_none) -> true
+ | (Pdir_string a0, Pdir_string b0) -> eq_string (a0, b0)
+ | (Pdir_int a0, Pdir_int b0) -> eq_int (a0, b0)
+ | (Pdir_ident a0, Pdir_ident b0) -> Longident.eq_t (a0, b0)
+ | (Pdir_bool a0, Pdir_bool b0) -> eq_bool (a0, b0)
+ | (_, _) -> false
+and eq_toplevel_phrase :
+ (toplevel_phrase * toplevel_phrase) -> 'result =
+ function
+ | (Ptop_def a0, Ptop_def b0) -> eq_structure (a0, b0)
+ | (Ptop_dir (a0, a1), Ptop_dir (b0, b1)) ->
+ (eq_string (a0, b0)) && (eq_directive_argument (a1, b1))
+ | (_, _) -> false
(* *)
(***********************************************************************)
-(* $Id: lexer299.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The lexer definition *)
{
(* *)
(***********************************************************************)
-(* $Id: lexer301.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The lexer definition *)
{
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
+# #
+# Copyright 1995 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
$1=="enum" {n=0; next; }
{for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
# #
#########################################################################
-# $Id: make-package-macosx 12783 2012-07-26 12:37:40Z doligez $
-
cd package-macosx
rm -rf ocaml.pkg ocaml-rw.dmg
# stop here -> |
cat >resources/ReadMe.txt <<EOF
This package installs OCaml version ${VERSION}.
-You need Mac OS X 10.7.x (Lion), with the
+You need Mac OS X 10.7.x (Lion) or later, with the
XCode tools installed (v4.3.3 or later).
Files will be installed in the following directories:
chmod -R g-w root
sudo chown -R root:wheel root
-/Developer/Applications/Utilities/PackageMaker.app/Contents/MacOS/PackageMaker \
+# HOW TO INSTALL PackageMaker:
+# Get PackageMaker.app from
+# https://developer.apple.com/downloads/index.action?name=Auxiliary
+# It's in the "Auxiliary Tools for Xcode" download.
+# Copy it to /Applications/.
+/Applications/PackageMaker.app/Contents/MacOS/PackageMaker \
-build -p "`pwd`/ocaml.pkg" -f "`pwd`/root" -i "`pwd`/Info.plist" \
-d "`pwd`/Description.plist" -r "`pwd`/resources"
major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`"
minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`"
-patchlevel="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`"
+patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`"
suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`"
echo "#define OCAML_VERSION_MAJOR $major"
echo "#define OCAML_VERSION_MINOR $minor"
-case $patchlevel in "") patchlevel=0;; esac
-echo "#define OCAML_VERSION_PATCHLEVEL $patchlevel"
+case $patchlvl in "") patchlvl=0;; esac
+echo "#define OCAML_VERSION_PATCHLEVEL $patchlvl"
case "$suffix" in
"") echo "#undef OCAML_VERSION_ADDITIONAL";;
*) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";;
(* *)
(***********************************************************************)
-(* $Id: objinfo.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files
and on bytecode executables. *)
end
let arg_list = []
-let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0)
+let arg_usage =
+ Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0)
let main() =
Arg.parse arg_list dump_obj arg_usage;
int main(int argc, char ** argv)
{
- fprintf(stderr, "BFD library unavailable, cannot print info on .cmxs files\n");
+ fprintf(stderr,"BFD library unavailable, cannot print info on .cmxs files\n");
return 2;
}
# #
#########################################################################
-# $Id: ocaml-objcopy-macosx 11156 2011-07-27 14:17:02Z doligez $
-
-
TMP="${TMPDIR=/tmp}"
TEMP="${TMP}"/ocaml-objcopy-$$.o
UNDEF="${TMP}"/ocaml-objcopy-$$.sym
(* *)
(***********************************************************************)
-(* $Id: ocaml299to3.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Lexer299
let input_buffer = Buffer.create 16383
print_endline
"Convert OCaml 2.99 O'Labl-style labels in implementation files to";
print_endline
- "a syntax compatible with version 3. Also `fun:' labels are replaced by `f:'.";
+ "a syntax compatible with version 3. Also `fun:' labels are replaced \
+ by `f:'.";
print_endline "Other syntactic changes are not handled.";
print_endline "Old files are renamed to <file>.bak.";
print_endline "Interface files do not need label syntax conversion.";
(* *)
(***********************************************************************)
-(* $Id: ocamlcp.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Printf
let compargs = ref ([] : string list)
let _cclib s = option_with_arg "-cclib" s
let _ccopt s = option_with_arg "-ccopt" s
let _config = option "-config"
+ let _compat_32 = option "-compat-32"
let _custom = option "-custom"
let _dllib = option_with_arg "-dllib"
let _dllpath = option_with_arg "-dllpath"
let _output_obj = option "-output-obj"
let _pack = option "-pack"
let _pp s = incompatible "-pp"
+ let _ppx s = incompatible "-ppx"
let _principal = option "-principal"
let _rectypes = option "-rectypes"
let _runtime_variant s = option_with_arg "-runtime-variant" s
+ let _short_paths = option "-short-paths"
let _strict_sequence = option "-strict-sequence"
let _thread () = option "-thread" ()
let _vmthread () = option "-vmthread" ()
let _warn_help = option "-warn-help"
let _where = option "-where"
let _nopervasives = option "-nopervasives"
+ let _dsource = option "-dsource"
let _dparsetree = option "-dparsetree"
+ let _dtypedtree = option "-dtypedtree"
let _drawlambda = option "-drawlambda"
let _dlambda = option "-dlambda"
let _dinstr = option "-dinstr"
(* *)
(***********************************************************************)
-(* $Id: ocamldep.ml 12759 2012-07-23 13:39:21Z lefessan $ *)
-
-open Longident
+open Compenv
open Parsetree
-
+let ppf = Format.err_formatter
(* Print the dependencies *)
type file_kind = ML | MLI;;
+let include_dirs = ref []
let load_path = ref ([] : (string * string array) list)
let ml_synonyms = ref [".ml"]
let mli_synonyms = ref [".mli"]
let native_only = ref false
-let force_slash = ref false
let error_occurred = ref false
let raw_dependencies = ref false
let sort_files = ref false
r
end
+(* Since we reinitialize load_path after reading OCAMLCOMP,
+ we must use a cache instead of calling Sys.readdir too often. *)
+module StringMap = Map.Make(String)
+let dirs = ref StringMap.empty
+let readdir dir =
+ try
+ StringMap.find dir !dirs
+ with Not_found ->
+ let contents =
+ try
+ Sys.readdir dir
+ with Sys_error msg ->
+ Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+ error_occurred := true;
+ [||]
+ in
+ dirs := StringMap.add dir contents !dirs;
+ contents
+
let add_to_load_path dir =
try
let dir = Misc.expand_directory Config.standard_library dir in
- let contents = Sys.readdir dir in
- load_path := !load_path @ [dir, contents]
+ let contents = readdir dir in
+ load_path := (dir, contents) :: !load_path
with Sys_error msg ->
Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
error_occurred := true
let (depends_on, escaped_eol) = (":", " \\\n ")
let print_filename s =
- let s = if !force_slash then fix_slash s else s in
+ let s = if !Clflags.force_slash then fix_slash s else s in
if not (String.contains s ' ') then begin
print_string s;
end else begin
deps;
print_char '\n'
-(* Optionally preprocess a source file *)
-
-let preprocessor = ref None
-
-exception Preprocessing_error
-
-let preprocess sourcefile =
- match !preprocessor with
- None -> sourcefile
- | Some pp ->
- flush Pervasives.stdout;
- let tmpfile = Filename.temp_file "ocamldep_pp" "" in
- let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
- if Sys.command comm <> 0 then begin
- Misc.remove_file tmpfile;
- raise Preprocessing_error
- end;
- tmpfile
-
-let remove_preprocessed inputfile =
- match !preprocessor with
- None -> ()
- | Some _ -> Misc.remove_file inputfile
-
-(* Parse a file or get a dumped syntax tree in it *)
-
-let is_ast_file ic ast_magic =
- try
- let buffer = Misc.input_bytes ic (String.length ast_magic) in
- if buffer = ast_magic then true
- else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
- failwith "OCaml and preprocessor have incompatible versions"
- else false
- with End_of_file -> false
-
-let parse_use_file ic =
- if is_ast_file ic Config.ast_impl_magic_number then
- let _source_file = input_value ic in
- [Ptop_def (input_value ic : Parsetree.structure)]
- else begin
- seek_in ic 0;
- let lb = Lexing.from_channel ic in
- Location.init lb !Location.input_name;
- Parse.use_file lb
- end
-
-let parse_interface ic =
- if is_ast_file ic Config.ast_intf_magic_number then
- let _source_file = input_value ic in
- (input_value ic : Parsetree.signature)
- else begin
- seek_in ic 0;
- let lb = Lexing.from_channel ic in
- Location.init lb !Location.input_name;
- Parse.interface lb
- end
(* Process one file *)
Syntaxerr.report_error err
| Sys_error msg ->
Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
- | Preprocessing_error ->
+ | Pparse.Error err ->
Format.fprintf Format.err_formatter
- "@[Preprocessing error on file %s@]@."
- source_file
+ "@[Preprocessing error on file %s@]@.@[%a@]@."
+ source_file
+ Pparse.report_error err
| x -> raise x
-let read_parse_and_extract parse_function extract_function source_file =
+let read_parse_and_extract parse_function extract_function magic source_file =
Depend.free_structure_names := Depend.StringSet.empty;
try
- let input_file = preprocess source_file in
- let ic = open_in_bin input_file in
- let cleanup () = close_in ic; remove_preprocessed input_file in
- try
- let ast = parse_function ic in
+ let input_file = Pparse.preprocess source_file in
+ begin try
+ let ast =
+ Pparse.file Format.err_formatter input_file parse_function magic in
extract_function Depend.StringSet.empty ast;
- cleanup ();
+ Pparse.remove_preprocessed input_file;
!Depend.free_structure_names
with x ->
- cleanup (); raise x
+ Pparse.remove_preprocessed input_file;
+ raise x
+ end
with x ->
report_err source_file x;
Depend.StringSet.empty
let ml_file_dependencies source_file =
- let extracted_deps = read_parse_and_extract
- parse_use_file Depend.add_use_file source_file
+ let parse_use_file_as_impl lexbuf =
+ let f x =
+ match x with
+ | Ptop_def s -> s
+ | Ptop_dir _ -> []
+ in
+ List.flatten (List.map f (Parse.use_file lexbuf))
+ in
+ let extracted_deps =
+ read_parse_and_extract parse_use_file_as_impl Depend.add_implementation
+ Config.ast_impl_magic_number source_file
in
if !sort_files then
files := (source_file, ML, !Depend.free_structure_names) :: !files
end
let mli_file_dependencies source_file =
- let extracted_deps = read_parse_and_extract
- parse_interface Depend.add_signature source_file in
+ let extracted_deps =
+ read_parse_and_extract Parse.interface Depend.add_signature
+ Config.ast_intf_magic_number source_file
+ in
if !sort_files then
files := (source_file, MLI, extracted_deps) :: !files
else
end
let file_dependencies_as kind source_file =
+ Compenv.readenv ppf Before_compile;
+ load_path := [];
+ List.iter add_to_load_path (
+ (!Compenv.last_include_dirs @
+ !include_dirs @
+ !Compenv.first_include_dirs
+ ));
Location.input_name := source_file;
try
if Sys.file_exists source_file then begin
let _ =
Clflags.classic := false;
- add_to_load_path Filename.current_dir_name;
+ first_include_dirs := Filename.current_dir_name :: !first_include_dirs;
+ Compenv.readenv ppf Before_args;
Arg.parse [
+ "-absname", Arg.Set Location.absname,
+ " Show absolute filenames in error messages";
"-all", Arg.Set all_dependencies,
" Generate dependencies on all files";
- "-I", Arg.String add_to_load_path,
+ "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs),
"<dir> Add <dir> to the list of include directories";
"-impl", Arg.String (file_dependencies_as ML),
"<f> Process <f> as a .ml file";
" Generate dependencies for native-code only (no .cmo files)";
"-one-line", Arg.Set one_line,
" Output one line per file, regardless of the length";
- "-pp", Arg.String(fun s -> preprocessor := Some s),
+ "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
"<cmd> Pipe sources through preprocessor <cmd>";
- "-slash", Arg.Set force_slash,
+ "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx),
+ "<cmd> Pipe abstract syntax trees through preprocessor <cmd>";
+ "-slash", Arg.Set Clflags.force_slash,
" (Windows) Use forward slash / instead of backslash \\ in file paths";
"-sort", Arg.Set sort_files,
" Sort files according to their dependencies";
"-vnum", Arg.Unit print_version_num,
" Print version number and exit";
] file_dependencies usage;
+ Compenv.readenv ppf Before_link;
if !sort_files then sort_files_by_dependencies !files;
exit (if !error_occurred then 2 else 0)
(* *)
(***********************************************************************)
-(* $Id: ocamlmklib.mlp 12723 2012-07-17 18:25:54Z doligez $ *)
-
open Printf
open Myocamlbuild_config
let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to ocamlc *)
and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *)
-and c_objs = ref [] (* .o, .a, .obj, .lib, .dll files to pass to mksharedlib and ar *)
+and c_objs = ref [] (* .o, .a, .obj, .lib, .dll files to pass
+ to mksharedlib and ar *)
and caml_libs = ref [] (* -cclib to pass to ocamlc, ocamlopt *)
and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *)
and dynlink = ref supports_shared_libraries
if !output_c = "" then output_c := !output
let usage = "\
-Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\
+Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\
+ .dll files>\
\nOptions are:\
\n -cclib <lib> C library passed to ocamlc -a or ocamlopt -a only\
\n -ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only\
(* *)
(***********************************************************************)
-(* $Id: ocamlmktop.ml 12477 2012-05-24 16:17:19Z xleroy $ *)
-
let _ =
let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in
- exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo"))
+ exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
+ ocamlbytecomp.cma ocamltoplevel.cma "
+ ^ args ^ " topstart.cmo"))
# #
#########################################################################
-# $Id: ocamlmktop.tpl 12477 2012-05-24 16:17:19Z xleroy $
-
-exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo
+exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
+ ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo
(* *)
(***********************************************************************)
-(* $Id: ocamlcp.ml 11890 2011-12-20 10:35:43Z frisch $ *)
-
open Printf
let compargs = ref ([] : string list)
let _p = option "-p"
let _pack = option "-pack"
let _pp s = incompatible "-pp"
+ let _ppx s = incompatible "-ppx"
let _principal = option "-principal"
let _rectypes = option "-rectypes"
let _runtime_variant s = option_with_arg "-runtime-variant" s
let _S = option "-S"
+ let _short_paths = option "-short-paths"
let _strict_sequence = option "-strict-sequence"
let _shared = option "-shared"
let _thread = option "-thread"
let _where = option "-where"
let _nopervasives = option "-nopervasives"
+ let _dsource = option "-dsource"
let _dparsetree = option "-dparsetree"
+ let _dtypedtree = option "-dtypedtree"
let _drawlambda = option "-drawlambda"
let _dlambda = option "-dlambda"
let _dclambda = option "-dclambda"
(* *)
(***********************************************************************)
-(* $Id: ocamlprof.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Printf
-open Clflags
-open Config
open Location
-open Misc
open Parsetree
(* User programs must not use identifiers that start with these prefixes. *)
done
let copy_chars_win32 nchars =
- for i = 1 to nchars do
+ for _i = 1 to nchars do
let c = input_char !inchan in
if c <> '\r' then output_char !outchan c
done
List.iter (rewrite_class_field iflag) cl.pcstr_fields
| Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
- | Pexp_open (_, e) -> rewrite_exp iflag e
+ | Pexp_open (_ovf, _, e) -> rewrite_exp iflag e
| Pexp_pack (smod) -> rewrite_mod iflag smod
and rewrite_ifbody iflag ghost sifbody =
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(**************************************************************************)
-
-(* Original Code from Ber-metaocaml, modified fo 3.12.0 and fixed *)
-
-(* Printing code expressions *)
-(* Authors: Ed Pizzi, Fabrice Le Fessant *)
-
-open Asttypes
-open Format
-open Location
-open Lexing
-open Parsetree
-
-
-(* borrowed from printast.ml *)
-let fmt_position f l =
- if l.pos_fname = "" && l.pos_lnum = 1
- then fprintf f "%d" l.pos_cnum
- else if l.pos_lnum = -1
- then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
- else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
- (l.pos_cnum - l.pos_bol)
-;;
-
-let fmt_location f loc =
- fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
- if loc.loc_ghost then fprintf f " ghost";
-;;
-
-let line i f s (*...*) =
- fprintf f "%s" (String.make (2*i) ' ');
- fprintf f s (*...*)
-;;
-
-let label i ppf x = line i ppf "label=\"%s\"\n" x;;
-
-(* end borrowing *)
-
-
-let indent = 1 ;; (* standard indentation increment *)
-let bar_on_first_case = true ;;
-
-(* These sets of symbols are taken from the manual. However, it's
- unclear what the sets infix_symbols and prefix_symbols are for, as
- operator_chars, which contains their union seems to be the only set
- useful to determine whether an identifier is prefix or infix.
- The set postfix_chars I added, which is the set of characters allowed
- at the end of an identifier to allow for internal MetaOCaml variable
- renaming. *)
-
-let prefix_symbols = [ '!'; '?'; '~' ] ;;
-let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-';
- '*'; '/'; '$'; '%' ] ;;
-let operator_chars = [ '!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/';
- ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~' ] ;;
-let numeric_chars = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ] ;;
-
-type fixity =
- | Infix
- | Prefix ;;
-
-let is_infix fx =
- match fx with
- | Infix -> true
- | Prefix -> false ;;
-
-let special_infix_strings =
- ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ] ;;
-
-
-(*
-let is_special_infix_string s =
- List.exists (fun x -> (x = s)) special_infix_strings ;;
-*)
-
-let is_in_list e l = List.exists (fun x -> (x = e)) l
-
-
-(* determines if the string is an infix string.
- checks backwards, first allowing a renaming postfix ("_102") which
- may have resulted from Pexp -> Texp -> Pexp translation, then checking
- if all the characters in the beginning of the string are valid infix
- characters. *)
-let fixity_of_string s =
- if ((is_in_list s special_infix_strings)
- || (is_in_list (String.get s 0) infix_symbols)) then Infix else Prefix
-
-let fixity_of_longident li =
- match li.txt with
- | Longident.Lident name ->
- fixity_of_string name
-(* This is wrong (and breaks RTT):
- | Longident.Ldot (_, name)
- when is_in_list name special_infix_strings -> Infix
-*)
- | _ -> Prefix ;;
-
-let fixity_of_exp e =
- match e.pexp_desc with
- | Pexp_ident (li) ->
- (fixity_of_longident li)
-(*
- | Pexp_cspval (_,li) ->
- if false (* default valu of !Clflags.prettycsp *)
- then (fixity_of_longident li)
- else Prefix
-*)
- | _ -> Prefix ;;
-
-let rec fmt_longident_aux f x =
- match x with
- | Longident.Lident s -> fprintf f "%s" s;
- | Longident.Ldot(y, s) when is_in_list s special_infix_strings ->
- fprintf f "%a.( %s )@ " fmt_longident_aux y s
-(* This is wrong (and breaks RTT):
- fprintf f "@ %s@ " s
-*)
- | Longident.Ldot (y, s) ->
- begin
- match s.[0] with
- 'a'..'z' | 'A'..'Z' ->
- fprintf f "%a.%s" fmt_longident_aux y s
- | _ ->
- fprintf f "%a.( %s )@ " fmt_longident_aux y s
-
- end
-
- | Longident.Lapply (y, z) ->
- fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
-;;
-
-let fmt_longident ppf x = fprintf ppf "%a" fmt_longident_aux x.txt;;
-
-let fmt_char f c =
- let i = int_of_char c in
- if (i < 32) || (i >= 128) then
- fprintf f "'\\%03d'" (Char.code c)
- else
- match c with
- '\'' | '\\' ->
- fprintf f "'\\%c'" c
- | _ ->
- fprintf f "'%c'" c;;
-
-let fmt_constant f x =
- match x with
- | Const_int (i) ->
- if (i < 0) then fprintf f "(%d)" i
- else fprintf f "%d" i;
- | Const_char (c) -> fprintf f "%a" fmt_char c ;
- | Const_string (s) ->
- fprintf f "%S" s;
- | Const_float (s) ->
- if ((String.get s 0) = '-') then fprintf f "(%s)" s
- else fprintf f "%s" s;
- (* maybe parenthesize all floats for consistency? *)
- | Const_int32 (i) ->
- if i < 0l then fprintf f "(%ldl)" i
- else fprintf f "%ldl" i;
- | Const_int64 (i) ->
- if i < 0L then fprintf f "(%LdL)" i
- else fprintf f "%LdL" i;
- | Const_nativeint (i) ->
- if i < 0n then
- fprintf f "(%ndn)" i
- else fprintf f "%ndn" i;
-;;
-
-let fmt_mutable_flag ppf x =
- match x with
- | Immutable -> ();
- | Mutable -> fprintf ppf "mutable ";
-;;
-
-let string ppf s =
- fprintf ppf "%s" s ;;
-
-let text ppf s =
- fprintf ppf "%s" s.txt ;;
-
-let constant_string ppf s =
- fprintf ppf "\"%s\"" (String.escaped s) ;;
-
-let fmt_virtual_flag f x =
- match x with
- | Virtual -> fprintf f "virtual ";
- | Concrete -> ();
-;;
-
-let list f ppf l =
- let n = List.length l in
- List.iteri (fun i fmt ->
- f ppf fmt;
- if i < n-1 then
- Format.fprintf ppf "\n")
- l;;
-
-(* List2 - applies f to each element in list l, placing break hints
- and a separator string between the resulting outputs. *)
-
-let rec list2 f ppf l ?(indent=0) ?(space=1) ?(breakfirst=false)
- ?(breaklast=false) sep =
- match l with
- [] -> if (breaklast=true) then pp_print_break ppf space indent;
- | (last::[]) ->
- if (breakfirst=true) then pp_print_break ppf space indent;
- f ppf last;
- if (breaklast=true) then pp_print_break ppf space indent;
- | (first::rest) ->
- if (breakfirst=true) then pp_print_break ppf space indent;
- f ppf first ;
- fprintf ppf sep;
- pp_print_break ppf space indent;
- list2 f ppf rest ~indent:indent ~space:space
- ~breakfirst:false ~breaklast:breaklast sep ;;
-
-let type_var_print ppf str =
- fprintf ppf "'%s" str.txt ;;
-
-let type_var_option_print ppf str =
- match str with
- None -> () (* TODO check *)
- | Some str ->
- fprintf ppf "'%s" str.txt ;;
-
-let fmt_class_params ppf (l, loc) =
- let length = (List.length l) in
- if (length = 0) then ()
- else if (length = 1) then
- fprintf ppf "%s@ " (List.hd l)
- else begin
- fprintf ppf "(" ;
- list2 string ppf l "," ;
- fprintf ppf ")@ " ;
- end ;;
-
-let fmt_class_params_def ppf (l, loc) =
- let length = (List.length l) in
- if (length = 0) then ()
- else begin
- fprintf ppf "[" ;
- list2 type_var_print ppf l "," ;
- fprintf ppf "]@ ";
- end ;;
-
-let fmt_rec_flag f x =
- match x with
- | Nonrecursive -> ();
- | Recursive | Default -> fprintf f " rec";
- (* todo - what is "default" recursion??
- this seemed safe, as it's better to falsely make a non-recursive
- let recursive than the opposite. *)
-;;
-
-let fmt_direction_flag ppf x =
- match x with
- | Upto -> fprintf ppf "to" ;
- | Downto -> fprintf ppf "downto" ;
-;;
-
-let fmt_private_flag f x =
- match x with
- | Public -> () ; (* fprintf f "Public"; *)
- | Private -> fprintf f "private ";
-;;
-
-let option f ppf x = (* DELETE *)
- match x with
- | None -> () ;
- | Some x ->
- line 0 ppf "Some\n";
- f ppf x;
-;;
-
-let option_quiet_p f ppf x =
- match x with
- | None -> ();
- | Some x ->
- fprintf ppf "@ (" ;
- f ppf x;
- fprintf ppf ")";
-;;
-
-let option_quiet f ppf x =
- match x with
- | None -> ();
- | Some x ->
- fprintf ppf "@ " ;
- f ppf x;
-;;
-
-let rec expression_is_terminal_list exp =
- match exp with
- | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]")}, None, _)}
- -> true ;
- | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::")},
- Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)}
- -> (expression_is_terminal_list exp2)
- | {pexp_desc = _}
- -> false
-;;
-
-let rec core_type ppf x =
- match x.ptyp_desc with
- | Ptyp_any -> fprintf ppf "_"; (* done *)
- | Ptyp_var (s) -> fprintf ppf "'%s" s; (* done *)
- | Ptyp_arrow (l, ct1, ct2) -> (* done *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- (match l with
- | "" -> core_type ppf ct1;
- | s when (String.get s 0 = '?') ->
- (match ct1.ptyp_desc with
- | Ptyp_constr ({ txt = Longident.Lident ("option")}, l) ->
- fprintf ppf "%s :@ " s ;
- type_constr_list ppf l ;
- | _ -> core_type ppf ct1; (* todo: what do we do here? *)
- );
- | s ->
- fprintf ppf "%s :@ " s ;
- core_type ppf ct1; (* todo: what do we do here? *)
- );
- fprintf ppf "@ ->@ " ;
- core_type ppf ct2 ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;
- | Ptyp_tuple l -> (* done *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- list2 core_type ppf l " *" ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;
- | Ptyp_constr (li, l) -> (* done *)
- pp_open_hovbox ppf indent ;
- type_constr_list ppf ~space:true l ;
- fprintf ppf "%a" fmt_longident li ;
- pp_close_box ppf () ;
- | Ptyp_variant (l, closed, low) ->
- pp_open_hovbox ppf indent ;
- (match closed with
- | true -> fprintf ppf "[ " ;
- | false -> fprintf ppf "[> " ;
- );
- list2 type_variant_helper ppf l " |" ;
- fprintf ppf " ]";
- pp_close_box ppf () ;
- | Ptyp_object (l) ->
- if ((List.length l) > 0) then begin
- pp_open_hovbox ppf indent ;
- fprintf ppf "< " ;
- list2 core_field_type ppf l " ;" ;
- fprintf ppf " >" ;
- pp_close_box ppf () ;
- end else fprintf ppf "< >" ;
-(* line i ppf "Ptyp_object\n";
- list i core_field_type ppf l; *)
- | Ptyp_class (li, l, low) -> (* done... sort of *)
- pp_open_hovbox ppf indent ;
- list2 core_type ppf l ~breaklast:true "" ;
- fprintf ppf "#%a" fmt_longident li;
- if ((List.length low) < 0) then begin (* done, untested *)
- fprintf ppf "@ [> " ;
- list2 class_var ppf low "" ;
- fprintf ppf " ]";
- end ;
- pp_close_box ppf ();
-(* line i ppf "Ptyp_class %a\n" fmt_longident li;
- list i core_type ppf l;
- list i string ppf low *)
- | Ptyp_alias (ct, s) -> (* done *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- core_type ppf ct ;
- fprintf ppf "@ as@ '%s)" s;
- pp_close_box ppf () ;
- | Ptyp_poly (sl, ct) -> (* done? *)
- pp_open_hovbox ppf indent ;
- if ((List.length sl) > 0) then begin
- list2 (fun ppf x -> fprintf ppf "'%s" x) ppf sl ~breaklast:true "";
- fprintf ppf ".@ " ;
- end ;
- core_type ppf ct ;
- pp_close_box ppf () ;
- | Ptyp_package (lid, cstrs) ->
- fprintf ppf "(module %a@ " fmt_longident lid;
- pp_open_hovbox ppf indent;
- begin match cstrs with
- [] -> ()
- | _ ->
- fprintf ppf "@ with@ ";
- string_x_core_type_ands ppf cstrs ;
- end;
- pp_close_box ppf ();
- fprintf ppf ")";
-
-and class_var ppf s =
- fprintf ppf "`%s" s ;
-
-and core_field_type ppf x =
- match x.pfield_desc with
- | Pfield (s, ct) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "%s :@ " s;
- core_type ppf ct;
- pp_close_box ppf () ;
- | Pfield_var ->
- fprintf ppf "..";
-
-and type_constr_list ppf ?(space=false) l =
- match (List.length l) with
- | 0 -> ()
- | 1 -> list2 core_type ppf l "" ;
- if (space) then fprintf ppf " " ;
- | _ -> fprintf ppf "(" ;
- list2 core_type ppf l "," ;
- fprintf ppf ")" ;
- if (space) then fprintf ppf " " ;
-
-and pattern_with_label ppf x s =
- if (s = "") then simple_pattern ppf x
- else begin
- let s =
- if (String.get s 0 = '?') then begin
- fprintf ppf "?" ;
- String.sub s 1 ((String.length s) - 1)
- end else begin
- fprintf ppf "~" ;
- s
- end in
- fprintf ppf "%s" s ;
- match x.ppat_desc with
- | Ppat_var (s2) ->
- if (s <> s2.txt) then begin
- fprintf ppf ":" ;
- simple_pattern ppf x ;
- end
- | _ -> fprintf ppf ":" ;
- simple_pattern ppf x
- end ;
-
-and pattern_with_when ppf whenclause x =
- match whenclause with
- | None -> pattern ppf x ;
- | Some (e) ->
- pp_open_hovbox ppf indent ;
- pattern ppf x ;
- fprintf ppf "@ when@ " ;
- expression ppf e ;
- pp_close_box ppf () ;
-
-and pattern ppf x =
- match x.ppat_desc with
- | Ppat_construct (li, po, b) ->
- pp_open_hovbox ppf indent ;
- (match li.txt,po with
- | Longident.Lident("::"),
- Some ({ppat_desc = Ppat_tuple([pat1; pat2])}) ->
- fprintf ppf "(" ;
- pattern ppf pat1 ;
- fprintf ppf "@ ::@ " ;
- pattern_list_helper ppf pat2 ;
- fprintf ppf ")";
- | _,_ ->
- fprintf ppf "%a" fmt_longident li;
- option_quiet pattern_in_parens ppf po;);
- pp_close_box ppf () ;
-(* OXX what is this boolean ??
- bool i ppf b; *)
-
- | _ ->
- simple_pattern ppf x
-
-and simple_pattern ppf x =
- match x.ppat_desc with
- | Ppat_construct (li, None, _) ->
- fprintf ppf "%a@ " fmt_longident li
- | Ppat_any -> fprintf ppf "_"; (* OXX done *)
- | Ppat_var ({txt = txt}) ->
- if (is_infix (fixity_of_string txt)) || List.mem txt.[0] prefix_symbols then
- fprintf ppf "(%s)" txt (* OXX done *)
- else
- fprintf ppf "%s" txt;
- | Ppat_alias (p, s) -> (* OXX done ... *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- pattern ppf p ;
- fprintf ppf " as@ %s)" s.txt;
- pp_close_box ppf () ;
- | Ppat_constant (c) -> (* OXX done *)
- fprintf ppf "%a" fmt_constant c;
- | Ppat_tuple (l) -> (* OXX done *)
- fprintf ppf "@[<hov 1>(";
- list2 pattern ppf l ",";
- fprintf ppf "@])";
- | Ppat_variant (l, po) ->
- (match po with
- | None ->
- fprintf ppf "`%s" l;
- | Some (p) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "(`%s@ " l ;
- pattern ppf p ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;
- );
- | Ppat_record (l, closed) -> (* OXX done *)
- fprintf ppf "{" ;
- list2 longident_x_pattern ppf l ";" ;
- begin match closed with
- Open -> fprintf ppf "_ ";
- | Closed -> ()
- end;
- fprintf ppf "}" ;
- | Ppat_array (l) -> (* OXX done *)
- pp_open_hovbox ppf 2 ;
- fprintf ppf "[|" ;
- list2 pattern ppf l ";" ;
- fprintf ppf "|]" ;
- pp_close_box ppf () ;
- | Ppat_or (p1, p2) -> (* OXX done *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- pattern ppf p1 ;
- fprintf ppf "@ | " ;
- pattern ppf p2 ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;
- | Ppat_constraint (p, ct) -> (* OXX done, untested *)
- fprintf ppf "(" ;
- pattern ppf p ;
- fprintf ppf " :" ;
- pp_print_break ppf 1 indent ;
- core_type ppf ct ;
- fprintf ppf ")" ;
- | Ppat_type (li) -> (* OXX done *)
- fprintf ppf "#%a" fmt_longident li ;
- | Ppat_lazy p ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "(lazy @ ";
- pattern ppf p ;
- fprintf ppf ")" ;
- pp_close_box ppf ()
- | Ppat_unpack (s) ->
- fprintf ppf "(module@ %s)@ " s.txt
- | _ ->
- fprintf ppf "@[<hov 1>(";
- pattern ppf x;
- fprintf ppf "@])";
-
-and simple_expr ppf x =
- match x.pexp_desc with
- | Pexp_construct (li, None, _) ->
- fprintf ppf "%a@ " fmt_longident li
- | Pexp_ident (li) -> (* was (li, b) *)
- if is_infix (fixity_of_longident li)
- || match li.txt with
- | Longident.Lident (li) -> List.mem li.[0] prefix_symbols
- | _ -> false
- then
- fprintf ppf "(%a)" fmt_longident li
- else
- fprintf ppf "%a" fmt_longident li ;
- | Pexp_constant (c) -> fprintf ppf "%a" fmt_constant c;
- | Pexp_pack (me) ->
- fprintf ppf "(module@ ";
- pp_open_hovbox ppf indent;
- module_expr ppf me;
- pp_close_box ppf ();
- fprintf ppf ")";
- | Pexp_newtype (lid, e) ->
- fprintf ppf "fun (type %s)@ " lid;
- expression ppf e
- | Pexp_tuple (l) ->
- fprintf ppf "@[<hov 1>(";
- list2 simple_expr ppf l ",";
- fprintf ppf ")@]";
- | Pexp_variant (l, eo) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "`%s" l ;
- option_quiet expression ppf eo ;
- pp_close_box ppf () ;
- | Pexp_record (l, eo) ->
- pp_open_hovbox ppf indent ; (* maybe just 1? *)
- fprintf ppf "{" ;
- begin
- match eo with
- None -> ()
- | Some e ->
- expression ppf e;
- fprintf ppf "@ with@ "
- end;
- list2 longident_x_expression ppf l ";" ;
- fprintf ppf "}" ;
- pp_close_box ppf () ;
- | Pexp_array (l) ->
- pp_open_hovbox ppf 2 ;
- fprintf ppf "[|" ;
- list2 simple_expr ppf l ";" ;
- fprintf ppf "|]" ;
- pp_close_box ppf () ;
- | Pexp_while (e1, e2) ->
- pp_open_hvbox ppf 0 ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "while@ " ;
- expression ppf e1 ;
- fprintf ppf " do" ;
- pp_close_box ppf () ;
- pp_print_break ppf 1 indent ;
- expression_sequence ppf e2 ~first:false;
- pp_print_break ppf 1 0 ;
- fprintf ppf "done" ;
- pp_close_box ppf () ;
- | Pexp_for (s, e1, e2, df, e3) ->
- pp_open_hvbox ppf 0 ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "for %s =@ " s.txt ;
- expression ppf e1 ;
- fprintf ppf "@ %a@ " fmt_direction_flag df ;
- expression ppf e2 ;
- fprintf ppf " do" ;
- pp_close_box ppf () ;
-
- pp_print_break ppf 1 indent ;
- expression_sequence ppf ~first:false e3 ;
- pp_print_break ppf 1 0 ;
- fprintf ppf "done" ;
- pp_close_box ppf () ;
-
-
- | _ ->
- fprintf ppf "(@ ";
- expression ppf x;
- fprintf ppf "@ )"
-
-and expression ppf x =
- match x.pexp_desc with
- | Pexp_let (rf, l, e) ->
- let l1 = (List.hd l) in
- let l2 = (List.tl l) in
- pp_open_hvbox ppf 0 ;
- pp_open_hvbox ppf indent ;
- fprintf ppf "let%a " fmt_rec_flag rf;
- pattern_x_expression_def ppf l1;
- pattern_x_expression_def_list ppf l2;
- pp_close_box ppf () ;
- fprintf ppf " in" ;
- pp_print_space ppf () ;
- expression_sequence ppf ~first:false ~indent:0 e ;
- pp_close_box ppf () ;
- | Pexp_function (label, None, [
- { ppat_desc = Ppat_var { txt ="*opt*" } },
- { pexp_desc = Pexp_let (_, [
- arg ,
- { pexp_desc = Pexp_match (_, [ _; _, eo ] ) } ], e) }
- ]
- ) ->
- expression ppf { x with pexp_desc = Pexp_function(label, Some eo,
- [arg, e]) }
-
- | Pexp_function (p, eo, l) ->
- if (List.length l = 1) then begin
- pp_open_hvbox ppf indent;
- fprintf ppf "fun " ;
- pattern_x_expression_case_single ppf (List.hd l) eo p
- end else begin
- pp_open_hvbox ppf 0;
- fprintf ppf "function" ;
- option_quiet expression_in_parens ppf eo ;
- pp_print_space ppf () ;
- pattern_x_expression_case_list ppf l ;
- end ;
- pp_close_box ppf ();
- | Pexp_apply (e, l) -> (* was (e, l, _) *)
- let fixity = (is_infix (fixity_of_exp e)) in
- let sd =
- (match e.pexp_desc with
- | Pexp_ident ({ txt = Longident.Ldot (Longident.Lident(modname), valname) })
- -> (modname, valname)
- | Pexp_ident ({ txt = Longident.Lident(valname) })
- -> ("",valname)
- | _ -> ("",""))
- in
- (match sd,l with
- | ("Array", "get"), [(_,exp1) ; (_,exp2)] ->
- pp_open_hovbox ppf indent;
- (match exp1.pexp_desc with
- | Pexp_ident (_) ->
- expression ppf exp1 ;
- | _ ->
- expression_in_parens ppf exp1 ;
- );
- fprintf ppf ".";
- expression_in_parens ppf exp2;
- pp_close_box ppf ();
- | ("Array", "set"), [(_,array) ; (_,index) ; (_, valu)] ->
- pp_open_hovbox ppf indent;
- (match array.pexp_desc with
- | Pexp_ident (_) ->
- expression ppf array ;
- | _ ->
- expression_in_parens ppf array ;
- );
- fprintf ppf ".";
- expression_in_parens ppf index;
- fprintf ppf "@ <-@ ";
- expression ppf valu;
- pp_close_box ppf ();
- | ("","!"),[(_,exp1)] ->
- fprintf ppf "!" ;
- simple_expr ppf exp1 ;
-(* | ("","raise"),[(_,exp)] ->
- fprintf ppf "raising [" ;
- expression ppf exp;
- fprintf ppf "], says %s" st; *)
- | (_,_) ->
- pp_open_hovbox ppf (indent + 1) ;
- fprintf ppf "(" ;
- if (fixity = false) then
- begin
- (match e.pexp_desc with
- | Pexp_ident(_) -> expression ppf e ;
- | Pexp_send (_,_) -> expression ppf e ;
- | _ -> pp_open_hovbox ppf indent;
- expression_in_parens ppf e ;
- pp_close_box ppf () );
- fprintf ppf "@ " ;
- list2 label_x_expression_param ppf l "";
- end
- else begin
- match l with
- [ arg1; arg2 ] ->
- label_x_expression_param ppf arg1 ;
- pp_print_space ppf () ;
- (match e.pexp_desc with
- | Pexp_ident(li) ->
-(* override parenthesization of infix identifier *)
- fprintf ppf "%a" fmt_longident li ;
- | _ -> simple_expr ppf e) ;
- pp_print_space ppf () ;
- label_x_expression_param ppf arg2
- | _ ->
-(* fprintf ppf "(" ; *)
- simple_expr ppf e ;
-(* fprintf ppf ")" ; *)
- list2 label_x_expression_param ppf l ~breakfirst:true ""
- end ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;)
- | Pexp_match (e, l) ->
- fprintf ppf "(" ;
- pp_open_hvbox ppf 0;
- pp_open_hovbox ppf 2;
- fprintf ppf "match@ " ;
- expression ppf e ;
- fprintf ppf " with" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- pattern_x_expression_case_list ppf l ;
- pp_close_box ppf () ;
- fprintf ppf ")" ;
- | Pexp_try (e, l) ->
- fprintf ppf "(";
- pp_open_vbox ppf 0; (* <-- always break here, says style manual *)
- pp_open_hvbox ppf 0;
- fprintf ppf "try";
- pp_print_break ppf 1 indent ;
- expression_sequence ppf ~first:false e;
- pp_print_break ppf 1 0;
- fprintf ppf "with";
- pp_close_box ppf ();
- pp_print_cut ppf ();
- pattern_x_expression_case_list ppf l ;
- pp_close_box ppf ();
- fprintf ppf ")";
- | Pexp_construct (li, eo, b) ->
- (match li.txt with
- | Longident.Lident ("::") ->
- (match eo with
- Some ({pexp_desc = Pexp_tuple ([exp1 ; exp2])}) ->
- pp_open_hovbox ppf indent ;
- if (expression_is_terminal_list exp2) then begin
- fprintf ppf "[" ;
- simple_expr ppf exp1 ;
- expression_list_helper ppf exp2 ;
- fprintf ppf "]" ;
- end else begin
- pp_open_hovbox ppf indent ;
- fprintf ppf "(@ ";
- simple_expr ppf exp1 ;
- fprintf ppf " ) ::@ " ;
- expression_list_nonterminal ppf exp2 ;
- fprintf ppf "@ " ;
- pp_close_box ppf () ;
- end ;
- pp_close_box ppf () ;
- | _ -> assert false
- );
- | Longident.Lident ("()") -> fprintf ppf "()" ;
- | _ ->
- fprintf ppf "(";
- pp_open_hovbox ppf indent ;
- fmt_longident ppf li;
- option_quiet expression_in_parens ppf eo;
- pp_close_box ppf () ;
- fprintf ppf ")"
- );
- | Pexp_field (e, li) ->
- pp_open_hovbox ppf indent ;
- (match e.pexp_desc with
- | Pexp_ident (_) ->
- simple_expr ppf e ;
- | _ ->
- expression_in_parens ppf e ;
- );
- fprintf ppf ".%a" fmt_longident li ;
- pp_close_box ppf () ;
- | Pexp_setfield (e1, li, e2) ->
- pp_open_hovbox ppf indent ;
- (match e1.pexp_desc with
- | Pexp_ident (_) ->
- simple_expr ppf e1 ;
- | _ ->
- expression_in_parens ppf e1 ;
- );
- fprintf ppf ".%a" fmt_longident li;
- fprintf ppf "@ <-@ ";
- expression ppf e2;
- pp_close_box ppf () ;
- | Pexp_ifthenelse (e1, e2, eo) ->
- fprintf ppf "@[<hv 0>" ;
- expression_if_common ppf e1 e2 eo;
- fprintf ppf "@]";
-
- | Pexp_sequence (e1, e2) ->
- fprintf ppf "@[<hv 0>begin" ;
- pp_print_break ppf 1 indent ;
-(* "@;<1 2>" ; *)
- expression_sequence ppf ~first:false x ;
- fprintf ppf "@;<1 0>end@]" ;
- | Pexp_constraint (e, cto1, cto2) ->
- (match (cto1, cto2) with
- | (None, None) -> expression ppf e ;
- | (Some (x1), Some (x2)) ->
- pp_open_hovbox ppf 2 ;
- fprintf ppf "(" ;
- expression ppf e ;
- fprintf ppf " :@ " ;
- core_type ppf x1 ;
- fprintf ppf " :>@ " ;
- core_type ppf x2 ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;
- | (Some (x), None) ->
- pp_open_hovbox ppf 2 ;
- fprintf ppf "(" ;
- expression ppf e ;
- fprintf ppf " :@ " ;
- core_type ppf x ;
- fprintf ppf ")" ;
- pp_close_box ppf ()
- | (None, Some (x)) ->
- pp_open_hovbox ppf 2 ;
- fprintf ppf "(" ;
- expression ppf e ;
- fprintf ppf " :>@ " ;
- core_type ppf x ;
- fprintf ppf ")" ;
- pp_close_box ppf ()
- )
- | Pexp_when (e1, e2) ->
- assert false ;
-(* This is a wierd setup. The ocaml phrase
- "pattern when condition -> expression"
- found in pattern matching contexts is encoded as:
- "pattern -> when condition expression"
- Thus, the when clause ("when condition"), which one might expect
- to be part of the pattern, is encoded as part of the expression
- following the pattern.
- A "when clause" should never exist in a vaccum. It should always
- occur in a pattern matching context and be printed as part of the
- pattern (in pattern_x_expression_case_list).
- Thus these Pexp_when expressions are printed elsewhere, and if
- this code is executed, an error has occurred. *)
- | Pexp_send (e, s) ->
- pp_open_hovbox ppf indent;
- (match e.pexp_desc with
- | Pexp_ident(_) ->
- expression ppf e;
- fprintf ppf "#%s" s;
- | _ ->
- fprintf ppf "(" ;
- expression_in_parens ppf e;
- fprintf ppf "@,#%s" s;
- fprintf ppf ")"
- );
- pp_close_box ppf (); (* bug fixed? *)
- | Pexp_new (li) ->
- pp_open_hovbox ppf indent;
- fprintf ppf "new@ %a" fmt_longident li;
- pp_close_box ppf ();
- | Pexp_setinstvar (s, e) ->
- pp_open_hovbox ppf indent;
- fprintf ppf "%s <-@ " s.txt;
- expression ppf e;
- pp_close_box ppf ();
- | Pexp_override (l) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "{< " ;
- if ((List.length l) > 0) then begin
- list2 string_x_expression ppf l ";";
- fprintf ppf " " ;
- end ;
- fprintf ppf ">}" ;
- pp_close_box ppf () ;
- | Pexp_letmodule (s, me, e) ->
- pp_open_hvbox ppf 0 ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "let module %s =@ " s.txt ;
- module_expr ppf me ;
- fprintf ppf " in" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- expression_sequence ppf ~first:false ~indent:0 e ;
- pp_close_box ppf () ;
- | Pexp_assert (e) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "assert@ " ;
- expression ppf e ;
- pp_close_box ppf () ;
- | Pexp_assertfalse ->
- fprintf ppf "assert false" ;
- | Pexp_lazy (e) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "lazy@ " ;
- simple_expr ppf e ;
- pp_close_box ppf () ;
- | Pexp_poly (e, cto) ->
-(* should this even print by itself? *)
- (match cto with
- | None -> expression ppf e ;
- | Some (ct) ->
- pp_open_hovbox ppf indent ;
- expression ppf e ;
- fprintf ppf "@ (* poly:@ " ;
- core_type ppf ct ;
- fprintf ppf " *)" ;
- pp_close_box ppf () );
- | Pexp_object cs ->
- pp_open_hovbox ppf indent ;
- class_structure ppf cs ;
- pp_close_box ppf () ;
- | Pexp_open (lid, e) ->
- pp_open_hvbox ppf 0 ;
- fprintf ppf "let open@ %a in@ " fmt_longident lid;
- expression_sequence ppf ~first:false ~indent:0 e ;
- pp_close_box ppf () ;
- | _ -> simple_expr ppf x
-
-
-and value_description ppf x =
- pp_open_hovbox ppf indent ;
- core_type ppf x.pval_type;
- if ((List.length x.pval_prim) > 0) then begin
- fprintf ppf " =@ " ;
- list2 constant_string ppf x.pval_prim "";
- end ;
- pp_close_box ppf () ;
-
-and type_declaration ppf x =
- pp_open_hovbox ppf indent ;
- (match x.ptype_manifest with
- | None -> ()
- | Some(y) ->
- core_type ppf y;
- match x.ptype_kind with
- | Ptype_variant _ | Ptype_record _ -> fprintf ppf " = "
- | Ptype_abstract -> ());
- (match x.ptype_kind with
- | Ptype_variant (first::rest) ->
- pp_open_hovbox ppf indent ;
-
- pp_open_hvbox ppf 0 ;
- type_variant_leaf ppf first true ;
- type_variant_leaf_list ppf rest ;
-(* string_x_core_type_list ppf lst; *)
- pp_close_box ppf () ;
-
- pp_close_box ppf () ;
- | Ptype_variant [] ->
- assert false ;
- | Ptype_abstract -> ()
- | Ptype_record l ->
-
- pp_open_hovbox ppf indent ;
-
- fprintf ppf "{" ;
- pp_print_break ppf 0 indent ;
- pp_open_hvbox ppf 0;
- list2 type_record_field ppf l ";" ;
- pp_close_box ppf () ;
- fprintf ppf "@," ;
- pp_close_box ppf () ;
- fprintf ppf "}" ;
-
- pp_close_box ppf () ;
- );
- list2 typedef_constraint ppf x.ptype_cstrs ~breakfirst:true "" ;
- pp_close_box ppf () ;
-
-and exception_declaration ppf x =
- match x with
- | [] -> ()
- | first::rest ->
- fprintf ppf "@ of@ ";
- list2 core_type ppf x " *";
-
-and class_type ppf x =
- match x.pcty_desc with
- | Pcty_signature (cs) ->
- class_signature ppf cs;
- | Pcty_constr (li, l) ->
- pp_open_hovbox ppf indent ;
- (match l with
- | [] -> ()
- | _ -> fprintf ppf "[" ;
- list2 core_type ppf l "," ;
- fprintf ppf "]@ " );
- fprintf ppf "%a" fmt_longident li ;
- pp_close_box ppf () ;
- | Pcty_fun (l, co, cl) ->
- pp_open_hovbox ppf indent ;
- core_type ppf co ;
- fprintf ppf " ->@ " ;
- (match l with
- | "" -> () ;
- | _ -> fprintf ppf "[%s] " l ); (* todo - what's l *)
- class_type ppf cl ;
- pp_close_box ppf () ;
-
-and class_signature ppf { pcsig_self = ct; pcsig_fields = l } =
- pp_open_hvbox ppf 0;
- pp_open_hovbox ppf indent ;
- fprintf ppf "object";
- (match ct.ptyp_desc with
- | Ptyp_any -> ()
- | _ -> fprintf ppf "@ (";
- core_type ppf ct;
- fprintf ppf ")" );
- pp_close_box ppf () ;
- list2 class_type_field ppf l ~indent:indent ~breakfirst:true "";
- pp_print_break ppf 1 0;
- fprintf ppf "end";
-
-and class_type_field ppf x =
- match x.pctf_desc with
- | Pctf_inher (ct) -> (* todo: test this *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "inherit@ " ;
- class_type ppf ct ;
- pp_close_box ppf () ;
- | Pctf_val (s, mf, vf, ct) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "val %s%s%s :@ "
- (match mf with
- | Mutable -> "mutable "
- | _ -> "")
- (match vf with
- | Virtual -> "virtual "
- | _ -> "")
- s;
- core_type ppf ct ;
- pp_close_box ppf () ;
- | Pctf_virt (s, pf, ct) -> (* todo: test this *)
- pp_open_hovbox ppf indent ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "method@ %avirtual@ %s" fmt_private_flag pf s ;
- pp_close_box ppf () ;
- fprintf ppf " :@ " ;
- core_type ppf ct ;
- pp_close_box ppf () ;
- | Pctf_meth (s, pf, ct) ->
- pp_open_hovbox ppf indent ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "method %a%s" fmt_private_flag pf s;
- pp_close_box ppf () ;
- fprintf ppf " :@ " ;
- core_type ppf ct ;
- pp_close_box ppf () ;
- | Pctf_cstr (ct1, ct2) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "constraint@ " ;
- core_type ppf ct1;
- fprintf ppf " =@ " ;
- core_type ppf ct2;
- pp_close_box ppf () ;
-
-and class_description ppf x =
- pp_open_hvbox ppf 0 ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "class %a%a%s :" fmt_virtual_flag x.pci_virt
- fmt_class_params_def x.pci_params x.pci_name.txt ;
- pp_close_box ppf () ;
- pp_print_break ppf 1 indent ;
- class_type ppf x.pci_expr ;
- pp_close_box ppf () ;
-
-and class_type_declaration ppf x =
- class_type_declaration_ext ppf true x ;
-
-and class_type_declaration_ext ppf first x =
- pp_open_hvbox ppf 0;
- pp_open_hovbox ppf indent ;
- fprintf ppf "%s@ %a%a%s =" (if (first) then "class type" else "and")
- fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params
- x.pci_name.txt ;
- pp_close_box ppf ();
- pp_print_break ppf 1 indent ;
- class_type ppf x.pci_expr;
- pp_close_box ppf ();
-
-and class_type_declaration_list ppf ?(first=true) l =
- if (first) then pp_open_hvbox ppf 0 ;
- match l with
- | [] -> if (first) then pp_close_box ppf () ;
- | h :: [] ->
- class_type_declaration_ext ppf first h ;
- pp_close_box ppf () ;
- | h :: t ->
- class_type_declaration_ext ppf first h ;
- pp_print_space ppf () ;
- class_type_declaration_list ppf ~first:false t ;
-
-and class_expr ppf x =
- match x.pcl_desc with
- | Pcl_structure (cs) ->
- class_structure ppf cs ;
- | Pcl_fun (l, eo, p, e) ->
- pp_open_hvbox ppf indent;
- pp_open_hovbox ppf indent;
- fprintf ppf "fun@ ";
- pattern ppf p;
- fprintf ppf " ->";
- pp_close_box ppf ();
- (match (eo, l) with
- | (None, "") -> () ;
- | (_,_) ->
- pp_open_hovbox ppf indent;
- fprintf ppf " (* eo: ";
- option expression ppf eo;
- fprintf ppf "@ label: ";
- label 0 ppf l;
- fprintf ppf " *)";
- pp_close_box ppf ()
- );
- fprintf ppf "@ ";
- class_expr ppf e;
- pp_close_box ppf ();
- | Pcl_let (rf, l, ce) ->
- let l1 = (List.hd l) in
- let l2 = (List.tl l) in
- pp_open_hvbox ppf 0 ;
- pp_open_hvbox ppf indent ;
- fprintf ppf "let%a " fmt_rec_flag rf;
- pattern_x_expression_def ppf l1;
- pattern_x_expression_def_list ppf l2;
- pp_close_box ppf () ;
- pp_close_box ppf () ;
- fprintf ppf " in" ;
- pp_print_space ppf () ;
- class_expr ppf ce;
- | Pcl_apply (ce, l) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "(";
- class_expr ppf ce;
- list2 label_x_expression_param ppf l ~breakfirst:true "";
- fprintf ppf ")";
- pp_close_box ppf () ;
- | Pcl_constr (li, l) ->
- pp_open_hovbox ppf indent;
- if ((List.length l) != 0) then begin
- fprintf ppf "[" ;
- list2 core_type ppf l "," ;
- fprintf ppf "]@ " ;
- end ;
- fprintf ppf "%a" fmt_longident li;
- pp_close_box ppf ();
- | Pcl_constraint (ce, ct) ->
- pp_open_hovbox ppf indent;
- fprintf ppf "(";
- class_expr ppf ce;
- fprintf ppf "@ : ";
- class_type ppf ct;
- fprintf ppf ")";
- pp_close_box ppf ();
-
-and class_structure ppf { pcstr_pat = p; pcstr_fields = l } =
- pp_open_hvbox ppf 0 ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "object" ;
- (match p.ppat_desc with
- | Ppat_any -> ();
- | _ -> fprintf ppf "@ " ;
- pattern_in_parens ppf p );
- pp_close_box ppf () ;
- list2 class_field ppf l ~indent:indent ~breakfirst:true "";
- fprintf ppf "@ end" ;
- pp_close_box ppf () ;
-
-and override ovf = match ovf with
- Override -> "!"
- | Fresh -> ""
-
-and class_field ppf x =
- match x.pcf_desc with
- | Pcf_inher (ovf, ce, so) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "inherit%s@ " (override ovf);
- class_expr ppf ce;
- (match so with
- | None -> ();
- | Some (s) -> fprintf ppf "@ as %s" s );
- pp_close_box ppf ();
- | Pcf_val (s, mf, ovf, e) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "val%s %a%s =@ " (override ovf) fmt_mutable_flag mf s.txt ;
- expression_sequence ppf ~indent:0 e ;
- pp_close_box ppf () ;
- | Pcf_virt (s, pf, ct) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "method virtual %a%s" fmt_private_flag pf s.txt ;
- fprintf ppf " :@ " ;
- core_type ppf ct;
- pp_close_box ppf () ;
- | Pcf_valvirt (s, mf, ct) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "val virtual %s%s"
- (match mf with
- | Mutable -> "mutable "
- | _ -> "")
- s.txt;
- fprintf ppf " :@ " ;
- core_type ppf ct;
- pp_close_box ppf () ;
- | Pcf_meth (s, pf, ovf, e) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "method%s %a%s" (override ovf) fmt_private_flag pf s.txt ;
- (match e.pexp_desc with
- | Pexp_poly (e, Some(ct)) ->
- fprintf ppf " :@ " ;
- core_type ppf ct ;
- fprintf ppf " =@ " ;
- expression ppf e ;
- | _ ->
- fprintf ppf " =@ " ;
- expression ppf e;
- ) ;
-(* special Pexp_poly handling? *)
- pp_close_box ppf () ;
- | Pcf_constr (ct1, ct2) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "constraint@ ";
- core_type ppf ct1;
- fprintf ppf " =@ " ;
- core_type ppf ct2;
- pp_close_box ppf ();
-(* | Pcf_let (rf, l) ->
-(* at the time that this was written, Pcf_let was commented out
- of the parser, rendering this untestable. In the interest of
- completeness, the following code is designed to print what
- the parser seems to expect *)
-(* todo: test this, eventually *)
- let l1 = (List.hd l) in
- let l2 = (List.tl l) in
- pp_open_hvbox ppf indent ;
- fprintf ppf "let%a " fmt_rec_flag rf;
- pattern_x_expression_def ppf l1;
- pattern_x_expression_def_list ppf l2;
- fprintf ppf " in" ;
- pp_close_box ppf () ; *)
- | Pcf_init (e) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "initializer@ " ;
- expression_sequence ppf ~indent:0 e ;
- pp_close_box ppf () ;
-
-and class_fun_helper ppf e =
- match e.pcl_desc with
- | Pcl_fun (l, eo, p, e) ->
- pattern ppf p;
- fprintf ppf "@ ";
- (match (eo, l) with
- | (None, "") -> () ;
- | (_,_) ->
- fprintf ppf "(* ";
- option expression ppf eo;
- label 0 ppf l;
- fprintf ppf " *)@ "
- );
- class_fun_helper ppf e;
- | _ ->
- e;
-
-and class_declaration_list ppf ?(first=true) l =
- match l with
- | [] ->
- if (first = false) then pp_close_box ppf ();
- | cd::l ->
- let s = (if first then begin pp_open_hvbox ppf 0 ; "class" end
- else begin pp_print_space ppf () ; "and" end) in
- class_declaration ppf ~str:s cd ;
- class_declaration_list ppf ~first:false l ;
-
-and class_declaration ppf ?(str="class") x =
- pp_open_hvbox ppf indent ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "%s %a%a%s@ " str fmt_virtual_flag x.pci_virt
- fmt_class_params_def x.pci_params x.pci_name.txt ;
- let ce =
- (match x.pci_expr.pcl_desc with
- | Pcl_fun (l, eo, p, e) ->
- class_fun_helper ppf x.pci_expr;
- | _ -> x.pci_expr) in
- let ce =
- (match ce.pcl_desc with
- | Pcl_constraint (ce, ct) ->
- fprintf ppf ":@ " ;
- class_type ppf ct ;
- fprintf ppf "@ " ;
- ce
- | _ -> ce ) in
- fprintf ppf "=" ;
- pp_close_box ppf () ;
- fprintf ppf "@ " ;
- class_expr ppf ce ;
- pp_close_box ppf () ;
-
-and module_type ppf x =
- match x.pmty_desc with
- | Pmty_ident (li) ->
- fprintf ppf "%a" fmt_longident li;
- | Pmty_signature (s) ->
- pp_open_hvbox ppf 0;
- fprintf ppf "sig";
- list2 signature_item ppf s ~breakfirst:true ~indent:indent "";
- pp_print_break ppf 1 0;
- fprintf ppf "end";
- pp_close_box ppf ();
- | Pmty_functor (s, mt1, mt2) ->
- pp_open_hvbox ppf indent;
- pp_open_hovbox ppf indent;
- fprintf ppf "functor@ (%s : " s.txt ;
- module_type ppf mt1;
- fprintf ppf ") ->";
- pp_close_box ppf ();
- pp_print_space ppf ();
- module_type ppf mt2;
- pp_close_box ppf ();
- | Pmty_with (mt, l) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- module_type ppf mt ;
- fprintf ppf "@ with@ " ;
- longident_x_with_constraint_list ppf l ;
- fprintf ppf ")" ;
- pp_close_box ppf () ;
- | Pmty_typeof me ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "module type of " ;
- module_expr ppf me ;
- pp_close_box ppf ()
-
-and signature ppf x = list signature_item ppf x
-
-and signature_item ppf x =
- begin
- match x.psig_desc with
- | Psig_type (l) ->
- let first = (List.hd l) in
- let rest = (List.tl l) in
- pp_open_hvbox ppf 0;
- pp_open_hvbox ppf 0;
- fprintf ppf "type " ;
- string_x_type_declaration ppf first;
- pp_close_box ppf ();
- type_def_list_helper ppf rest;
- pp_close_box ppf ();
- | Psig_value (s, vd) ->
- let intro = if vd.pval_prim = [] then "val" else "external" in
- pp_open_hovbox ppf indent ;
- if (is_infix (fixity_of_string s.txt))
- || List.mem s.txt.[0] prefix_symbols then
- fprintf ppf "%s ( %s ) :@ "
- intro s.txt (* OXX done *)
- else
- fprintf ppf "%s %s :@ " intro s.txt;
- value_description ppf vd;
- pp_close_box ppf () ;
- | Psig_exception (s, ed) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "exception %s" s.txt;
- exception_declaration ppf ed;
- pp_close_box ppf ();
- | Psig_class (l) ->
- pp_open_hvbox ppf 0 ;
- list2 class_description ppf l "";
- pp_close_box ppf () ;
- | Psig_module (s, mt) -> (* todo: check this *)
- pp_open_hovbox ppf indent ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "module@ %s :" s.txt ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_type ppf mt;
- pp_close_box ppf () ;
- | Psig_open (li) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "open@ %a" fmt_longident li ;
- pp_close_box ppf () ;
- | Psig_include (mt) -> (* todo: check this *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "include@ " ;
- module_type ppf mt;
- pp_close_box ppf () ;
- | Psig_modtype (s, md) -> (* todo: check this *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "module type %s" s.txt ;
- (match md with
- | Pmodtype_abstract -> ()
- | Pmodtype_manifest (mt) ->
- pp_print_space ppf () ;
- fprintf ppf " = " ;
- module_type ppf mt;
- );
- pp_close_box ppf () ;
- | Psig_class_type (l) ->
- class_type_declaration_list ppf l ;
- | Psig_recmodule decls ->
- pp_open_hvbox ppf 0 ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "module rec@ " ;
- string_x_module_type_list ppf decls ; (* closes hov box *)
- pp_close_box ppf () ;
- end;
- fprintf ppf "\n"
-
-and modtype_declaration ppf x =
- match x with
- | Pmodtype_abstract -> line 0 ppf "Pmodtype_abstract\n";
- | Pmodtype_manifest (mt) ->
- line 0 ppf "Pmodtype_manifest\n";
- module_type ppf mt;
-
-and module_expr ppf x =
- match x.pmod_desc with
- | Pmod_structure (s) ->
- pp_open_hvbox ppf 0;
- fprintf ppf "struct";
- list2 structure_item ppf s ~breakfirst:true ~indent:indent "";
- pp_print_break ppf 1 0;
- fprintf ppf "end";
- pp_close_box ppf (); (* bug fixed? *)
- | Pmod_constraint (me, mt) ->
- fprintf ppf "(";
- pp_open_hovbox ppf indent;
- module_expr ppf me;
- fprintf ppf " :@ "; (* <-- incorrect indentation? *)
- module_type ppf mt;
- pp_close_box ppf ();
- fprintf ppf ")";
- | Pmod_ident (li) ->
- fprintf ppf "%a" fmt_longident li;
- | Pmod_functor (s, mt, me) ->
- pp_open_hvbox ppf indent ;
- fprintf ppf "functor (%s : " s.txt;
- module_type ppf mt;
- fprintf ppf ") ->@ ";
- module_expr ppf me;
- pp_close_box ppf () ;
- | Pmod_apply (me1, me2) ->
- pp_open_hovbox ppf indent;
- fprintf ppf "(" ;
- module_expr ppf me1;
- fprintf ppf ")" ;
- pp_print_cut ppf ();
- fprintf ppf "(" ;
- module_expr ppf me2;
- fprintf ppf ")" ;
- pp_close_box ppf ();
- | Pmod_unpack e ->
- fprintf ppf "(val@ ";
- pp_open_hovbox ppf indent;
- expression ppf e;
- pp_close_box ppf ();
- fprintf ppf ")";
-
-and structure ppf x =
- list structure_item ppf x;
-
-(*
-(* closes one box *)
-and string_x_modtype_x_module ppf (s, _, mt, me) =
-(*
- (match me.pmod_desc with
- | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_)
- | Pmty_signature (_))} as mt)) ->
- (* assert false ; *) (* 3.07 - should this ever happen here? *)
- fprintf ppf "%s :@ " s ;
- module_type ppf mt ;
- fprintf ppf " =" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_expr ppf me ;
- | _ ->
-*)
- fprintf ppf "%s :@ " s;
- module_type ppf mt ;
- fprintf ppf " =" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_expr ppf me ;
-(* ) ; *)
-*)
-
-(* closes one box *)
-and text_x_modtype_x_module ppf (s, mt, me) =
-(*
- (match me.pmod_desc with
- | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_)
- | Pmty_signature (_))} as mt)) ->
- (* assert false ; *) (* 3.07 - should this ever happen here? *)
- fprintf ppf "%s :@ " s ;
- module_type ppf mt ;
- fprintf ppf " =" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_expr ppf me ;
- | _ ->
-*)
- fprintf ppf "%s :@ " s.txt;
- module_type ppf mt ;
- fprintf ppf " =" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_expr ppf me ;
-(* ) ; *)
-
-(*
-(* net gain of one box (-1, +2) *)
-and string_x_modtype_x_module_list ppf l =
- match l with
- | [] -> ()
- | hd :: tl ->
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- pp_open_hvbox ppf indent ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "and " ;
- string_x_modtype_x_module ppf hd; (* closes a box *)
- string_x_modtype_x_module_list ppf tl ; (* net open of one box *)
-*)
-
-(* net gain of one box (-1, +2) *)
-and text_x_modtype_x_module_list ppf l =
- match l with
- | [] -> ()
- | hd :: tl ->
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- pp_open_hvbox ppf indent ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "and " ;
- text_x_modtype_x_module ppf hd; (* closes a box *)
- text_x_modtype_x_module_list ppf tl ; (* net open of one box *)
-
-(* context: [hv [hov .]] returns [hv .]
- closes inner hov box. *)
-and string_x_module_type_list ppf ?(first=true) l =
- match l with
- | [] -> () ;
- | hd :: tl ->
- if (first=false) then begin
- pp_print_space ppf () ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "and " ;
- end ;
- string_x_module_type ppf hd ;
- pp_close_box ppf () ;
- string_x_module_type_list ppf ~first:false tl ;
-
-and string_x_module_type ppf (s, mty) =
- fprintf ppf "%s :@ " s.txt ;
- module_type ppf mty ;
-
-and structure_item ppf x =
- begin
- match x.pstr_desc with
- | Pstr_eval (e) ->
- pp_open_hvbox ppf 0 ;
- fprintf ppf "let _ = " ;
- expression_sequence ppf ~first:false ~indent:0 e ;
- pp_close_box ppf () ;
- | Pstr_type [] -> assert false
- | Pstr_type (first :: rest) ->
- pp_open_vbox ppf 0;
- pp_open_hvbox ppf 0;
- fprintf ppf "type " ;
- string_x_type_declaration ppf first;
- pp_close_box ppf ();
- type_def_list_helper ppf rest;
- pp_close_box ppf ();
- | Pstr_value (rf, l) ->
- let l1 = (List.hd l) in
- let l2 = (List.tl l) in
- pp_open_hvbox ppf 0 ;
- pp_open_hvbox ppf indent ;
- fprintf ppf "let%a " fmt_rec_flag rf;
- pattern_x_expression_def ppf l1;
- pattern_x_expression_def_list ppf l2;
- pp_close_box ppf () ;
- pp_close_box ppf () ;
- | Pstr_exception (s, ed) ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "exception@ %s" s.txt;
- exception_declaration ppf ed;
- pp_close_box ppf () ;
- | Pstr_module (s, me) ->
- pp_open_hvbox ppf indent;
- pp_open_hovbox ppf indent ;
- fprintf ppf "module %s" s.txt ;
- (match me.pmod_desc with
- | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_)
- | Pmty_signature (_))} as mt)) ->
- fprintf ppf " :@ " ;
- module_type ppf mt ;
- fprintf ppf " =" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_expr ppf me ;
- | _ ->
- fprintf ppf " =" ;
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- module_expr ppf me ;
- ) ;
- pp_close_box ppf ();
- | Pstr_open (li) ->
- fprintf ppf "open %a" fmt_longident li;
- | Pstr_modtype (s, mt) ->
- pp_open_hovbox ppf indent;
- fprintf ppf "module type %s =@ " s.txt;
- module_type ppf mt;
- pp_close_box ppf () ; (* bug fixed? *)
- | Pstr_class (l) ->
- class_declaration_list ppf l;
- | Pstr_class_type (l) ->
- class_type_declaration_list ppf l ;
- | Pstr_primitive (s, vd) ->
- pp_open_hovbox ppf indent ;
- let need_parens =
- match s.txt with
- | "or"
- | "mod"
- | "land"
- | "lor"
- | "lxor"
- | "lsl"
- | "lsr"
- | "asr"
- -> true
-
- | _ ->
- match s.txt.[0] with
- 'a'..'z' -> false
- | _ -> true
- in
- if need_parens then
- fprintf ppf "external@ ( %s ) :@ " s.txt
- else
- fprintf ppf "external@ %s :@ " s.txt;
- value_description ppf vd;
- pp_close_box ppf () ;
- | Pstr_include me ->
- pp_open_hovbox ppf indent ;
- fprintf ppf "include " ;
- module_expr ppf me ;
- pp_close_box ppf () ;
- | Pstr_exn_rebind (s, li) -> (* todo: check this *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "exception@ %s =@ %a" s.txt fmt_longident li ;
- pp_close_box ppf () ;
- | Pstr_recmodule decls -> (* 3.07 *)
- let l1 = (List.hd decls) in
- let l2 = (List.tl decls) in
- pp_open_hvbox ppf 0; (* whole recmodule box *)
- pp_open_hvbox ppf indent ; (* this definition box *)
- pp_open_hovbox ppf indent ; (* first line box *)
- fprintf ppf "module rec " ;
- text_x_modtype_x_module ppf l1; (* closes a box *)
- text_x_modtype_x_module_list ppf l2; (* net opens one box *)
- pp_close_box ppf () ;
- pp_close_box ppf () ;
- pp_close_box ppf () ;
- end;
- fprintf ppf "\n"
-
-and type_def_list_helper ppf l =
- match l with
- | [] -> ()
- | first :: rest ->
- pp_print_space ppf () ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "and " ;
- string_x_type_declaration ppf first;
- pp_close_box ppf () ;
- type_def_list_helper ppf rest ;
-
-and string_x_type_declaration ppf (s, td) =
- let l = td.ptype_params in
- (match (List.length l) with
- | 0 -> ()
- | 1 -> list2 type_var_option_print ppf l "" ;
- fprintf ppf " " ;
- | _ -> pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- list2 type_var_option_print ppf l "," ;
- fprintf ppf ")" ;
- pp_close_box ppf ();
- fprintf ppf " " ;
- );
- fprintf ppf "%s" s.txt ;
- (match (td.ptype_kind, td.ptype_manifest) with
- | Ptype_abstract, None -> ()
- | Ptype_record _, _ -> fprintf ppf " = " ;
- | _ , _ -> fprintf ppf " =" ;
- pp_print_break ppf 1 indent ;
- );
- type_declaration ppf td;
-
-and longident_x_with_constraint_list ?(first=true) ppf l =
- match l with
- | [] -> () ;
- | h :: [] ->
- if (first = false) then fprintf ppf "@ and " ;
- longident_x_with_constraint ppf h ;
- | h :: t ->
- if (first = false) then fprintf ppf "@ and " ;
- longident_x_with_constraint ppf h ;
- fprintf ppf "@ and " ;
- longident_x_with_constraint ppf h ;
- longident_x_with_constraint_list ~first:false ppf t;
-
-and string_x_core_type_ands ?(first=true) ppf l =
- match l with
- | [] -> () ;
- | h :: [] ->
- if (first = false) then fprintf ppf "@ and " ;
- string_x_core_type ppf h ;
- | h :: t ->
- if (first = false) then fprintf ppf "@ and " ;
- string_x_core_type ppf h;
- string_x_core_type_ands ~first:false ppf t;
-
-and string_x_core_type ppf (s, ct) =
- fprintf ppf "%a@ =@ %a" fmt_longident s core_type ct
-
-and longident_x_with_constraint ppf (li, wc) =
- match wc with
- | Pwith_type (td) ->
- fprintf ppf "type@ %a =@ " fmt_longident li;
- type_declaration ppf td ;
- | Pwith_module (li2) ->
- fprintf ppf "module %a =@ %a" fmt_longident li fmt_longident li2;
- | Pwith_typesubst td ->
- fprintf ppf "type@ %a :=@ " fmt_longident li;
- type_declaration ppf td ;
- | Pwith_modsubst (li2) ->
- fprintf ppf "module %a :=@ %a" fmt_longident li fmt_longident li2;
-
-and typedef_constraint ppf (ct1, ct2, l) =
- pp_open_hovbox ppf indent ;
- fprintf ppf "constraint@ " ;
- core_type ppf ct1;
- fprintf ppf " =@ " ;
- core_type ppf ct2;
- pp_close_box ppf () ;
-
-and type_variant_leaf ppf (s, l,_, _) first = (* TODO *)
- if (first) then begin
- pp_print_if_newline ppf ();
- pp_print_string ppf " ";
- end else begin
- pp_print_space ppf ();
- fprintf ppf "| " ;
- end ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "%s" s.txt ;
- if ((List.length l) > 0) then begin
- fprintf ppf "@ of@ " ;
- list2 core_type ppf l " *"
- end ;
- pp_close_box ppf ();
-
-and type_variant_leaf_list ppf list =
- match list with
- | [] -> ()
- | first :: rest ->
- type_variant_leaf ppf first false ;
- type_variant_leaf_list ppf rest ;
-
-and type_record_field ppf (s, mf, ct,_) =
- pp_open_hovbox ppf indent ;
- fprintf ppf "%a%s:" fmt_mutable_flag mf s.txt ;
- core_type ppf ct ;
- pp_close_box ppf () ;
-
-and longident_x_pattern ppf (li, p) =
- pp_open_hovbox ppf indent ;
- fprintf ppf "%a =@ " fmt_longident li;
- pattern ppf p;
- pp_close_box ppf () ;
-
-
-
-and pattern_x_expression_case_list
- ppf ?(first:bool=true) ?(special_first_case=bar_on_first_case)
- (l:(pattern * expression) list) =
- match l with
- | [] -> ()
- | (p,e)::[] -> (* last time *)
- if (first=false) then
- fprintf ppf "| " ;
- pp_open_hvbox ppf indent ;
- let (e,w) =
- (match e with
- | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1))
- | _ -> (e, None)) in
- pattern_with_when ppf w p ;
- fprintf ppf " ->@ " ;
- pp_open_hvbox ppf 0 ;
- expression_sequence ppf ~indent:0 e ;
- pp_close_box ppf () ;
- pp_close_box ppf () ;
- | (p,e)::r -> (* not last *)
- pp_open_hvbox ppf (indent + 2) ;
- if ((first=true) & (special_first_case=false)) then begin
- pp_print_if_newline ppf () ;
- pp_print_string ppf " "
- end else
- fprintf ppf "| " ;
- let (e,w) =
- (match e with
- | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1))
- | _ -> (e, None)) in
- pattern_with_when ppf w p ;
- fprintf ppf " ->@ " ;
- pp_open_hvbox ppf 0 ;
- expression_sequence ppf ~indent:0 e ;
- pp_close_box ppf () ;
- pp_close_box ppf () ;
- pp_print_break ppf 1 0;
- (pattern_x_expression_case_list ppf ~first:false r);
-
-and pattern_x_expression_def ppf (p, e) =
- pattern ppf p ;
- fprintf ppf " =@ " ;
- expression ppf e;
-
-and pattern_list_helper ppf p =
- match p with
- | {ppat_desc = Ppat_construct ({ txt = Longident.Lident("::") },
- Some ({ppat_desc = Ppat_tuple([pat1; pat2])}),
- _)}
- -> pattern ppf pat1 ;
- fprintf ppf "@ ::@ " ;
- pattern_list_helper ppf pat2 ;
- | _ -> pattern ppf p ;
-
-and string_x_expression ppf (s, e) =
- pp_open_hovbox ppf indent ;
- fprintf ppf "%s =@ " s.txt ;
- expression ppf e ;
- pp_close_box ppf () ;
-
-and longident_x_expression ppf (li, e) =
- pp_open_hovbox ppf indent ;
- fprintf ppf "%a =@ " fmt_longident li;
- simple_expr ppf e;
- pp_close_box ppf () ;
-
-and label_x_expression_param ppf (l,e) =
- match l with
- | "" -> simple_expr ppf e ;
- | lbl ->
- if ((String.get lbl 0) = '?') then begin
- fprintf ppf "%s:" lbl ;
- simple_expr ppf e ;
- end else begin
- fprintf ppf "~%s:" lbl ;
- simple_expr ppf e ;
- end ;
-
-and expression_in_parens ppf e =
- let already_has_parens =
- (match e.pexp_desc with
- Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Ldot (
- Longident.Lident(modname), funname) })},_)
- -> (match modname,funname with
- | "Array","get" -> false;
- | "Array","set" -> false;
- | _,_ -> true) ;
- | Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Lident(funname) })},_)
- -> (match funname with
- | "!" -> false;
- | _ -> true);
- | Pexp_apply (_,_) -> true;
- | Pexp_match (_,_) -> true;
- | Pexp_tuple (_) -> true ;
- | Pexp_constraint (_,_,_) -> true ;
- | _ -> false) in
- if (already_has_parens) then expression ppf e
- else begin
- fprintf ppf "(" ;
- expression ppf e ;
- fprintf ppf ")" ;
- end ;
-
-and pattern_in_parens ppf p =
- let already_has_parens =
- match p.ppat_desc with
- | Ppat_alias (_,_) -> true
- | Ppat_tuple (_) -> true
- | Ppat_or (_,_) -> true
- | Ppat_constraint (_,_) -> true
- | _ -> false in
- if (already_has_parens) then pattern ppf p
- else begin
- fprintf ppf "(" ;
- pattern ppf p ;
- fprintf ppf ")" ;
- end;
-
-and pattern_constr_params_option ppf po =
- match po with
- | None -> ();
- | Some pat ->
- pp_print_space ppf ();
- pattern_in_parens ppf pat;
-
-and type_variant_helper ppf x =
- match x with
- | Rtag (l, b, ctl) -> (* is b important? *)
- pp_open_hovbox ppf indent ;
- fprintf ppf "`%s" l ;
- if ((List.length ctl) != 0) then begin
- fprintf ppf " of@ " ;
- list2 core_type ppf ctl " *" ;
- end ;
- pp_close_box ppf () ;
- | Rinherit (ct) ->
- core_type ppf ct
-
-(* prints a list of definitions as found in a let statement
- note! breaks "open and close boxes in same function" convention, however
- does always open and close the same number of boxes. (i.e. no "net
- gain or loss" of box depth. *)
-and pattern_x_expression_def_list ppf l =
- match l with
- | [] -> ()
- | hd :: tl ->
- pp_close_box ppf () ;
- pp_print_space ppf () ;
- pp_open_hvbox ppf indent ;
- fprintf ppf "and " ;
- pattern_x_expression_def ppf hd;
- pattern_x_expression_def_list ppf tl ;
-
-(* end an if statement by printing an else phrase if there is an "else"
- statement in the ast. otherwise just close the box. *)
-(* added: special case for "else if" case *)
-
-and expression_eo ppf eo extra =
- match eo with
- | None -> ();
- | Some x ->
- if extra then fprintf ppf " "
- else fprintf ppf "@ " ;
- match x.pexp_desc with
- | Pexp_ifthenelse (e1, e2, eo) -> (* ... else if ...*)
- fprintf ppf "else" ;
- expression_elseif ppf (e1, e2, eo)
- | Pexp_sequence (e1, e2) ->
- fprintf ppf "else" ;
- expression_ifbegin ppf x; (* ... else begin ... end*)
- | _ -> (* ... else ... *)
- pp_open_hvbox ppf indent ;
- fprintf ppf "else@ " ;
- expression ppf x ;
- pp_close_box ppf () ;
-
-and expression_elseif ppf (e1,e2,eo) =
- fprintf ppf " " ;
- expression_if_common ppf e1 e2 eo ;
-
-and expression_ifbegin ppf e =
- fprintf ppf " begin";
- pp_print_break ppf 1 indent ; (* "@;<1 2>"; *)
- expression_sequence ppf e;
- pp_print_break ppf 1 0 ; (* fprintf ppf "@;<1 0>" *)
- fprintf ppf "end";
-
-and expression_if_common ppf e1 e2 eo =
- match eo, e2.pexp_desc with
- | None, Pexp_sequence (_, _) ->
- fprintf ppf "if@ " ;
- expression ppf e1;
- fprintf ppf "@ then@ " ;
- expression_ifbegin ppf e2
- | None, _ ->
- fprintf ppf "if@ " ;
- expression ppf e1;
- fprintf ppf "@ then@ " ;
- simple_expr ppf e2
- | Some _, Pexp_sequence _ ->
- fprintf ppf "if " ;
- expression ppf e1;
- fprintf ppf "@ then@ " ;
- expression_ifbegin ppf e2;
- expression_eo ppf eo true; (* ... then begin ... end *)
- | Some _, _ ->
- pp_open_hvbox ppf indent ;
- fprintf ppf "if " ;
- expression ppf e1;
- fprintf ppf " then@ " ;
- simple_expr ppf e2;
- pp_close_box ppf () ;
- expression_eo ppf eo false;
-
-and expression_sequence ppf ?(skip=1) ?(indent=indent) ?(first=true) expr =
- if (first = true) then begin
- pp_open_hvbox ppf 0 ;
- expression_sequence ppf ~skip:skip ~indent:0 ~first:false expr ;
- pp_close_box ppf () ;
- end else
- match expr.pexp_desc with
- | Pexp_sequence (e1, e2) ->
- simple_expr ppf e1 ;
- fprintf ppf ";" ;
- pp_print_break ppf skip indent ; (* "@;<1 2>" ; *)
- expression_sequence ppf ~skip:skip ~indent:indent ~first:false e2 ;
- | _ ->
- expression ppf expr ;
-
-and expression_list_helper ppf exp =
- match exp with
- | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)}
- -> () ;
- | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") },
- Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)}
- -> fprintf ppf ";@ " ;
- simple_expr ppf exp1 ;
- expression_list_helper ppf exp2 ;
- | {pexp_desc = _}
- -> assert false;
-
-and expression_list_nonterminal ppf exp =
- match exp with
- | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)}
- -> fprintf ppf "[]" ; (* assert false; *)
- | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") },
- Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)}
- -> simple_expr ppf exp1;
- fprintf ppf " ::@ ";
- expression_list_nonterminal ppf exp2;
- | {pexp_desc = _}
- -> expression ppf exp;
-;
-
-and directive_argument ppf x =
- match x with
- | Pdir_none -> ()
- | Pdir_string (s) -> fprintf ppf "@ \"%s\"" s;
- | Pdir_int (i) -> fprintf ppf "@ %d" i;
- | Pdir_ident (li) -> fprintf ppf "@ %a" fmt_longident_aux li;
- | Pdir_bool (b) -> fprintf ppf "@ %s" (string_of_bool b);
-
-and string_x_core_type_list ppf (s, l) =
- string ppf s;
- list core_type ppf l;
-
-and string_list_x_location ppf (l, loc) =
- line 0 ppf "<params> %a\n" fmt_location loc;
- list string ppf l;
-
-and pattern_x_expression_case_single ppf (p, e) eo lbl =
- (match eo with
- None -> pattern_with_label ppf p lbl
- | Some x ->
- fprintf ppf "?" ;
- pp_open_hovbox ppf indent ;
- fprintf ppf "(" ;
- begin
- match p.ppat_desc with
- Ppat_constraint ({ ppat_desc = Ppat_var s }, ct) ->
- fprintf ppf "%s@ :@ %a" s.txt core_type ct
- | Ppat_var s ->
- fprintf ppf "%s" s.txt
- | _ -> assert false
- end;
- fprintf ppf " =@ " ;
- expression ppf x ;
- fprintf ppf ")" ;
- pp_close_box ppf ()
- ) ;
- fprintf ppf " ->@ " ;
- expression_sequence ppf ~indent:0 e ;;
-
-let rec toplevel_phrase ppf x =
- match x with
- | Ptop_def (s) ->
- pp_open_hvbox ppf 0;
- list2 structure_item ppf s ~breakfirst:false ~indent:0 "";
- pp_close_box ppf ();
- | Ptop_dir (s, da) ->
- pp_open_hovbox ppf indent;
- fprintf ppf "#%s" s;
- directive_argument ppf da;
- pp_close_box ppf () ;;
-
-let expression ppf x =
- fprintf ppf "@[";
- expression ppf x;
- fprintf ppf "@]";;
-
-let string_of_expression x =
- ignore (flush_str_formatter ()) ;
- let ppf = str_formatter in
- expression ppf x ;
- flush_str_formatter () ;;
-
-let toplevel_phrase ppf x =
- pp_print_newline ppf () ;
- toplevel_phrase ppf x;
- fprintf ppf ";;" ;
- pp_print_newline ppf ();;
-
-let print_structure = structure
-let print_signature = signature
(* *)
(***********************************************************************)
-(* $Id: primreq.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Determine the set of C primitives required by the given .cmo and .cma
files *)
(* *)
(***********************************************************************)
-(* $Id: profiling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Run-time library for profiled programs *)
type profiling_counters = (string * (string * int array)) list
(* *)
(***********************************************************************)
-(* $Id: profiling.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Run-time library for profiled programs *)
val counters: (string * (string * int array)) list ref;;
(***********************************************************************)
(* *)
-(* Objective Caml *)
+(* OCaml *)
(* *)
(* Fabrice Le Fessant, INRIA Saclay *)
(* *)
(* *)
(***********************************************************************)
-(* $Id: scrapelabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open StdLabels
open Lexer301
*.a
*.so
*.obj
+*.lib
+*.dll
-*.cm[ioxa]
+*.cm[ioxat]
*.cmx[as]
+*.cmti
*.annot
*.result
*.byte
*.native
program
-program.exe
+*.exe
+*.exe.manifest
.depend
.depend.nt
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Asttypes
+open Typedtree
+
+let opt f = function None -> () | Some x -> f x
+
+let structure sub str =
+ List.iter (sub # structure_item) str.str_items
+
+let structure_item sub x =
+ match x.str_desc with
+ | Tstr_eval exp -> sub # expression exp
+ | Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list)
+ | Tstr_primitive (_id, _, v) -> sub # value_description v
+ | Tstr_type list ->
+ List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
+ | Tstr_exception (_id, _, decl) -> sub # exception_declaration decl
+ | Tstr_exn_rebind (_id, _, _p, _) -> ()
+ | Tstr_module (_id, _, mexpr) -> sub # module_expr mexpr
+ | Tstr_recmodule list ->
+ List.iter
+ (fun (_id, _, mtype, mexpr) ->
+ sub # module_type mtype;
+ sub # module_expr mexpr
+ )
+ list
+ | Tstr_modtype (_id, _, mtype) -> sub # module_type mtype
+ | Tstr_open _ -> ()
+ | Tstr_class list ->
+ List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
+ | Tstr_class_type list ->
+ List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) list
+ | Tstr_include (mexpr, _) -> sub # module_expr mexpr
+
+let value_description sub x =
+ sub # core_type x.val_desc
+
+let type_declaration sub decl =
+ List.iter
+ (fun (ct1, ct2, _loc) -> sub # core_type ct1; sub # core_type ct2)
+ decl.typ_cstrs;
+ begin match decl.typ_kind with
+ | Ttype_abstract -> ()
+ | Ttype_variant list ->
+ List.iter (fun (_s, _, cts, _loc) -> List.iter (sub # core_type) cts) list
+ | Ttype_record list ->
+ List.iter (fun (_s, _, _mut, ct, _loc) -> sub # core_type ct) list
+ end;
+ opt (sub # core_type) decl.typ_manifest
+
+let exception_declaration sub decl =
+ List.iter (sub # core_type) decl.exn_params
+
+let pattern sub pat =
+ let extra = function
+ | Tpat_type _
+ | Tpat_unpack -> ()
+ | Tpat_constraint ct -> sub # core_type ct
+ in
+ List.iter (fun (c, _) -> extra c) pat.pat_extra;
+ match pat.pat_desc with
+ | Tpat_any
+ | Tpat_var _
+ | Tpat_constant _ -> ()
+ | Tpat_tuple l
+ | Tpat_construct (_, _, l, _) -> List.iter (sub # pattern) l
+ | Tpat_variant (_, po, _) -> opt (sub # pattern) po
+ | Tpat_record (l, _) -> List.iter (fun (_, _, pat) -> sub # pattern pat) l
+ | Tpat_array l -> List.iter (sub # pattern) l
+ | Tpat_or (p1, p2, _) -> sub # pattern p1; sub # pattern p2
+ | Tpat_alias (p, _, _)
+ | Tpat_lazy p -> sub # pattern p
+
+let expression sub exp =
+ let extra = function
+ | Texp_constraint (cty1, cty2) ->
+ opt (sub # core_type) cty1; opt (sub # core_type) cty2
+ | Texp_open _
+ | Texp_newtype _ -> ()
+ | Texp_poly cto -> opt (sub # core_type) cto
+ in
+ List.iter (function (c, _) -> extra c) exp.exp_extra;
+ match exp.exp_desc with
+ | Texp_ident _
+ | Texp_constant _ -> ()
+ | Texp_let (rec_flag, list, exp) ->
+ sub # bindings (rec_flag, list);
+ sub # expression exp
+ | Texp_function (_, cases, _) ->
+ sub # bindings (Nonrecursive, cases)
+ | Texp_apply (exp, list) ->
+ sub # expression exp;
+ List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list
+ | Texp_match (exp, list, _) ->
+ sub # expression exp;
+ sub # bindings (Nonrecursive, list)
+ | Texp_try (exp, list) ->
+ sub # expression exp;
+ sub # bindings (Nonrecursive, list)
+ | Texp_tuple list ->
+ List.iter (sub # expression) list
+ | Texp_construct (_, _, args, _) ->
+ List.iter (sub # expression) args
+ | Texp_variant (_, expo) ->
+ opt (sub # expression) expo
+ | Texp_record (list, expo) ->
+ List.iter (fun (_, _, exp) -> sub # expression exp) list;
+ opt (sub # expression) expo
+ | Texp_field (exp, _, _label) ->
+ sub # expression exp
+ | Texp_setfield (exp1, _, _label, exp2) ->
+ sub # expression exp1;
+ sub # expression exp2
+ | Texp_array list ->
+ List.iter (sub # expression) list
+ | Texp_ifthenelse (exp1, exp2, expo) ->
+ sub # expression exp1;
+ sub # expression exp2;
+ opt (sub # expression) expo
+ | Texp_sequence (exp1, exp2) ->
+ sub # expression exp1;
+ sub # expression exp2
+ | Texp_while (exp1, exp2) ->
+ sub # expression exp1;
+ sub # expression exp2
+ | Texp_for (_id, _, exp1, exp2, _dir, exp3) ->
+ sub # expression exp1;
+ sub # expression exp2;
+ sub # expression exp3
+ | Texp_when (exp1, exp2) ->
+ sub # expression exp1;
+ sub # expression exp2
+ | Texp_send (exp, _meth, expo) ->
+ sub # expression exp;
+ opt (sub # expression) expo
+ | Texp_new (_path, _, _) -> ()
+ | Texp_instvar (_, _path, _) -> ()
+ | Texp_setinstvar (_, _, _, exp) ->
+ sub # expression exp
+ | Texp_override (_, list) ->
+ List.iter (fun (_path, _, exp) -> sub # expression exp) list
+ | Texp_letmodule (_id, _, mexpr, exp) ->
+ sub # module_expr mexpr;
+ sub # expression exp
+ | Texp_assert exp -> sub # expression exp
+ | Texp_assertfalse -> ()
+ | Texp_lazy exp -> sub # expression exp
+ | Texp_object (cl, _) ->
+ sub # class_structure cl
+ | Texp_pack (mexpr) ->
+ sub # module_expr mexpr
+
+
+let package_type sub pack =
+ List.iter (fun (_s, ct) -> sub # core_type ct) pack.pack_fields
+
+let signature sub sg =
+ List.iter (sub # signature_item) sg.sig_items
+
+let signature_item sub item =
+ match item.sig_desc with
+ | Tsig_value (_id, _, v) ->
+ sub # value_description v
+ | Tsig_type list ->
+ List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
+ | Tsig_exception (_id, _, decl) ->
+ sub # exception_declaration decl
+ | Tsig_module (_id, _, mtype) ->
+ sub # module_type mtype
+ | Tsig_recmodule list ->
+ List.iter (fun (_id, _, mtype) -> sub # module_type mtype) list
+ | Tsig_modtype (_id, _, mdecl) ->
+ sub # modtype_declaration mdecl
+ | Tsig_open _ -> ()
+ | Tsig_include (mty,_) -> sub # module_type mty
+ | Tsig_class list ->
+ List.iter (sub # class_description) list
+ | Tsig_class_type list ->
+ List.iter (sub # class_type_declaration) list
+
+let modtype_declaration sub mdecl =
+ match mdecl with
+ | Tmodtype_abstract -> ()
+ | Tmodtype_manifest mtype -> sub # module_type mtype
+
+let class_description sub cd =
+ sub # class_type cd.ci_expr
+
+let class_type_declaration sub cd =
+ sub # class_type cd.ci_expr
+
+let module_type sub mty =
+ match mty.mty_desc with
+ | Tmty_ident (_path, _) -> ()
+ | Tmty_signature sg -> sub # signature sg
+ | Tmty_functor (_id, _, mtype1, mtype2) ->
+ sub # module_type mtype1; sub # module_type mtype2
+ | Tmty_with (mtype, list) ->
+ sub # module_type mtype;
+ List.iter (fun (_, _, withc) -> sub # with_constraint withc) list
+ | Tmty_typeof mexpr ->
+ sub # module_expr mexpr
+
+let with_constraint sub cstr =
+ match cstr with
+ | Twith_type decl -> sub # type_declaration decl
+ | Twith_module _ -> ()
+ | Twith_typesubst decl -> sub # type_declaration decl
+ | Twith_modsubst _ -> ()
+
+let module_expr sub mexpr =
+ match mexpr.mod_desc with
+ | Tmod_ident (_p, _) -> ()
+ | Tmod_structure st -> sub # structure st
+ | Tmod_functor (_id, _, mtype, mexpr) ->
+ sub # module_type mtype;
+ sub # module_expr mexpr
+ | Tmod_apply (mexp1, mexp2, _) ->
+ sub # module_expr mexp1;
+ sub # module_expr mexp2
+ | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
+ sub # module_expr mexpr
+ | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+ sub # module_expr mexpr;
+ sub # module_type mtype
+ | Tmod_unpack (exp, _mty) ->
+ sub # expression exp
+(* sub # module_type mty *)
+
+let class_expr sub cexpr =
+ match cexpr.cl_desc with
+ | Tcl_constraint (cl, None, _, _, _ ) ->
+ sub # class_expr cl;
+ | Tcl_structure clstr -> sub # class_structure clstr
+ | Tcl_fun (_label, pat, priv, cl, _partial) ->
+ sub # pattern pat;
+ List.iter (fun (_id, _, exp) -> sub # expression exp) priv;
+ sub # class_expr cl
+ | Tcl_apply (cl, args) ->
+ sub # class_expr cl;
+ List.iter (fun (_label, expo, _) -> opt (sub # expression) expo) args
+ | Tcl_let (rec_flat, bindings, ivars, cl) ->
+ sub # bindings (rec_flat, bindings);
+ List.iter (fun (_id, _, exp) -> sub # expression exp) ivars;
+ sub # class_expr cl
+ | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+ sub # class_expr cl;
+ sub # class_type clty
+ | Tcl_ident (_, _, tyl) ->
+ List.iter (sub # core_type) tyl
+
+let class_type sub ct =
+ match ct.cltyp_desc with
+ | Tcty_signature csg -> sub # class_signature csg
+ | Tcty_constr (_path, _, list) -> List.iter (sub # core_type) list
+ | Tcty_fun (_label, ct, cl) ->
+ sub # core_type ct;
+ sub # class_type cl
+
+let class_signature sub cs =
+ sub # core_type cs.csig_self;
+ List.iter (sub # class_type_field) cs.csig_fields
+
+let class_type_field sub ctf =
+ match ctf.ctf_desc with
+ | Tctf_inher ct -> sub # class_type ct
+ | Tctf_val (_s, _mut, _virt, ct) ->
+ sub # core_type ct
+ | Tctf_virt (_s, _priv, ct) ->
+ sub # core_type ct
+ | Tctf_meth (_s, _priv, ct) ->
+ sub # core_type ct
+ | Tctf_cstr (ct1, ct2) ->
+ sub # core_type ct1;
+ sub # core_type ct2
+
+let core_type sub ct =
+ match ct.ctyp_desc with
+ | Ttyp_any -> ()
+ | Ttyp_var _s -> ()
+ | Ttyp_arrow (_label, ct1, ct2) ->
+ sub # core_type ct1;
+ sub # core_type ct2
+ | Ttyp_tuple list -> List.iter (sub # core_type) list
+ | Ttyp_constr (_path, _, list) ->
+ List.iter (sub # core_type) list
+ | Ttyp_object list ->
+ List.iter (sub # core_field_type) list
+ | Ttyp_class (_path, _, list, _labels) ->
+ List.iter (sub # core_type) list
+ | Ttyp_alias (ct, _s) ->
+ sub # core_type ct
+ | Ttyp_variant (list, _bool, _labels) ->
+ List.iter (sub # row_field) list
+ | Ttyp_poly (_list, ct) -> sub # core_type ct
+ | Ttyp_package pack -> sub # package_type pack
+
+let core_field_type sub cft =
+ match cft.field_desc with
+ | Tcfield_var -> ()
+ | Tcfield (_s, ct) -> sub # core_type ct
+
+let class_structure sub cs =
+ sub # pattern cs.cstr_pat;
+ List.iter (sub # class_field) cs.cstr_fields
+
+let row_field sub rf =
+ match rf with
+ | Ttag (_label, _bool, list) -> List.iter (sub # core_type) list
+ | Tinherit ct -> sub # core_type ct
+
+let class_field sub cf =
+ match cf.cf_desc with
+ | Tcf_inher (_ovf, cl, _super, _vals, _meths) ->
+ sub # class_expr cl
+ | Tcf_constr (cty, cty') ->
+ sub # core_type cty;
+ sub # core_type cty'
+ | Tcf_val (_lab, _, _, _mut, Tcfk_virtual cty, _override) ->
+ sub # core_type cty
+ | Tcf_val (_lab, _, _, _mut, Tcfk_concrete exp, _override) ->
+ sub # expression exp
+ | Tcf_meth (_lab, _, _priv, Tcfk_virtual cty, _override) ->
+ sub # core_type cty
+ | Tcf_meth (_lab, _, _priv, Tcfk_concrete exp, _override) ->
+ sub # expression exp
+ | Tcf_init exp ->
+ sub # expression exp
+
+let bindings sub (_rec_flag, list) =
+ List.iter (sub # binding) list
+
+let binding sub (pat, exp) =
+ sub # pattern pat;
+ sub # expression exp
+
+class iter = object(this)
+ method binding = binding this
+ method bindings = bindings this
+ method class_description = class_description this
+ method class_expr = class_expr this
+ method class_field = class_field this
+ method class_signature = class_signature this
+ method class_structure = class_structure this
+ method class_type = class_type this
+ method class_type_declaration = class_type_declaration this
+ method class_type_field = class_type_field this
+ method core_field_type = core_field_type this
+ method core_type = core_type this
+ method exception_declaration = exception_declaration this
+ method expression = expression this
+ method modtype_declaration = modtype_declaration this
+ method module_expr = module_expr this
+ method module_type = module_type this
+ method package_type = package_type this
+ method pattern = pattern this
+ method row_field = row_field this
+ method signature = signature this
+ method signature_item = signature_item this
+ method structure = structure this
+ method structure_item = structure_item this
+ method type_declaration = type_declaration this
+ method value_description = value_description this
+ method with_constraint = with_constraint this
+end
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Asttypes
+open Typedtree
+
+class iter: object
+ method binding: (pattern * expression) -> unit
+ method bindings: (rec_flag * (pattern * expression) list) -> unit
+ method class_description: class_description -> unit
+ method class_expr: class_expr -> unit
+ method class_field: class_field -> unit
+ method class_signature: class_signature -> unit
+ method class_structure: class_structure -> unit
+ method class_type: class_type -> unit
+ method class_type_declaration: class_type_declaration -> unit
+ method class_type_field: class_type_field -> unit
+ method core_field_type: core_field_type -> unit
+ method core_type: core_type -> unit
+ method exception_declaration: exception_declaration -> unit
+ method expression: expression -> unit
+ method modtype_declaration: modtype_declaration -> unit
+ method module_expr: module_expr -> unit
+ method module_type: module_type -> unit
+ method package_type: package_type -> unit
+ method pattern: pattern -> unit
+ method row_field: row_field -> unit
+ method signature: signature -> unit
+ method signature_item: signature_item -> unit
+ method structure: structure -> unit
+ method structure_item: structure_item -> unit
+ method type_declaration: type_declaration -> unit
+ method value_description: value_description -> unit
+ method with_constraint: with_constraint -> unit
+end
+(** Recursive iterator class. By inheriting from it and
+ overriding selected methods, it is possible to implement
+ custom behavior for specific kinds of nodes. *)
+
+(** {2 One-level iterators} *)
+
+(** The following functions apply the provided iterator to each
+ sub-component of the argument. *)
+
+val binding: iter -> (pattern * expression) -> unit
+val bindings: iter -> (rec_flag * (pattern * expression) list) -> unit
+val class_description: iter -> class_description -> unit
+val class_expr: iter -> class_expr -> unit
+val class_field: iter -> class_field -> unit
+val class_signature: iter -> class_signature -> unit
+val class_structure: iter -> class_structure -> unit
+val class_type: iter -> class_type -> unit
+val class_type_declaration: iter -> class_type_declaration -> unit
+val class_type_field: iter -> class_type_field -> unit
+val core_field_type: iter -> core_field_type -> unit
+val core_type: iter -> core_type -> unit
+val exception_declaration: iter -> exception_declaration -> unit
+val expression: iter -> expression -> unit
+val modtype_declaration: iter -> modtype_declaration -> unit
+val module_expr: iter -> module_expr -> unit
+val module_type: iter -> module_type -> unit
+val package_type: iter -> package_type -> unit
+val pattern: iter -> pattern -> unit
+val row_field: iter -> row_field -> unit
+val signature: iter -> signature -> unit
+val signature_item: iter -> signature_item -> unit
+val structure: iter -> structure -> unit
+val structure_item: iter -> structure_item -> unit
+val type_declaration: iter -> type_declaration -> unit
+val value_description: iter -> value_description -> unit
+val with_constraint: iter -> with_constraint -> unit
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(**************************************************************************)
-
-(*
-TODO:
- - 2012/05/10: Follow camlp4 way of building map and iter using classes
- and inheritance ?
-*)
-
-open Asttypes
-open Typedtree
-
-module type IteratorArgument = sig
-
- val enter_structure : structure -> unit
- val enter_value_description : value_description -> unit
- val enter_type_declaration : type_declaration -> unit
- val enter_exception_declaration :
- exception_declaration -> unit
- val enter_pattern : pattern -> unit
- val enter_expression : expression -> unit
- val enter_package_type : package_type -> unit
- val enter_signature : signature -> unit
- val enter_signature_item : signature_item -> unit
- val enter_modtype_declaration : modtype_declaration -> unit
- val enter_module_type : module_type -> unit
- val enter_module_expr : module_expr -> unit
- val enter_with_constraint : with_constraint -> unit
- val enter_class_expr : class_expr -> unit
- val enter_class_signature : class_signature -> unit
- val enter_class_declaration : class_declaration -> unit
- val enter_class_description : class_description -> unit
- val enter_class_type_declaration : class_type_declaration -> unit
- val enter_class_type : class_type -> unit
- val enter_class_type_field : class_type_field -> unit
- val enter_core_type : core_type -> unit
- val enter_core_field_type : core_field_type -> unit
- val enter_class_structure : class_structure -> unit
- val enter_class_field : class_field -> unit
- val enter_structure_item : structure_item -> unit
-
-
- val leave_structure : structure -> unit
- val leave_value_description : value_description -> unit
- val leave_type_declaration : type_declaration -> unit
- val leave_exception_declaration :
- exception_declaration -> unit
- val leave_pattern : pattern -> unit
- val leave_expression : expression -> unit
- val leave_package_type : package_type -> unit
- val leave_signature : signature -> unit
- val leave_signature_item : signature_item -> unit
- val leave_modtype_declaration : modtype_declaration -> unit
- val leave_module_type : module_type -> unit
- val leave_module_expr : module_expr -> unit
- val leave_with_constraint : with_constraint -> unit
- val leave_class_expr : class_expr -> unit
- val leave_class_signature : class_signature -> unit
- val leave_class_declaration : class_declaration -> unit
- val leave_class_description : class_description -> unit
- val leave_class_type_declaration : class_type_declaration -> unit
- val leave_class_type : class_type -> unit
- val leave_class_type_field : class_type_field -> unit
- val leave_core_type : core_type -> unit
- val leave_core_field_type : core_field_type -> unit
- val leave_class_structure : class_structure -> unit
- val leave_class_field : class_field -> unit
- val leave_structure_item : structure_item -> unit
-
- val enter_bindings : rec_flag -> unit
- val enter_binding : pattern -> expression -> unit
- val leave_binding : pattern -> expression -> unit
- val leave_bindings : rec_flag -> unit
-
- end
-
-module MakeIterator(Iter : IteratorArgument) : sig
-
- val iter_structure : structure -> unit
- val iter_signature : signature -> unit
- val iter_structure_item : structure_item -> unit
- val iter_signature_item : signature_item -> unit
- val iter_expression : expression -> unit
- val iter_module_type : module_type -> unit
- val iter_pattern : pattern -> unit
- val iter_class_expr : class_expr -> unit
-
- end = struct
-
- let may_iter f v =
- match v with
- None -> ()
- | Some x -> f x
-
-
- open Misc
- open Asttypes
-
- let rec iter_structure str =
- Iter.enter_structure str;
- List.iter iter_structure_item str.str_items;
- Iter.leave_structure str
-
-
- and iter_binding (pat, exp) =
- Iter.enter_binding pat exp;
- iter_pattern pat;
- iter_expression exp;
- Iter.leave_binding pat exp
-
- and iter_bindings rec_flag list =
- Iter.enter_bindings rec_flag;
- List.iter iter_binding list;
- Iter.leave_bindings rec_flag
-
- and iter_structure_item item =
- Iter.enter_structure_item item;
- begin
- match item.str_desc with
- Tstr_eval exp -> iter_expression exp
- | Tstr_value (rec_flag, list) ->
- iter_bindings rec_flag list
- | Tstr_primitive (id, _, v) -> iter_value_description v
- | Tstr_type list ->
- List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
- | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
- | Tstr_exn_rebind (id, _, p, _) -> ()
- | Tstr_module (id, _, mexpr) ->
- iter_module_expr mexpr
- | Tstr_recmodule list ->
- List.iter (fun (id, _, mtype, mexpr) ->
- iter_module_type mtype;
- iter_module_expr mexpr) list
- | Tstr_modtype (id, _, mtype) ->
- iter_module_type mtype
- | Tstr_open _ -> ()
- | Tstr_class list ->
- List.iter (fun (ci, _, _) ->
- Iter.enter_class_declaration ci;
- iter_class_expr ci.ci_expr;
- Iter.leave_class_declaration ci;
- ) list
- | Tstr_class_type list ->
- List.iter (fun (id, _, ct) ->
- Iter.enter_class_type_declaration ct;
- iter_class_type ct.ci_expr;
- Iter.leave_class_type_declaration ct;
- ) list
- | Tstr_include (mexpr, _) ->
- iter_module_expr mexpr
- end;
- Iter.leave_structure_item item
-
- and iter_value_description v =
- Iter.enter_value_description v;
- iter_core_type v.val_desc;
- Iter.leave_value_description v
-
- and iter_type_declaration decl =
- Iter.enter_type_declaration decl;
- List.iter (fun (ct1, ct2, loc) ->
- iter_core_type ct1;
- iter_core_type ct2
- ) decl.typ_cstrs;
- begin match decl.typ_kind with
- Ttype_abstract -> ()
- | Ttype_variant list ->
- List.iter (fun (s, _, cts, loc) ->
- List.iter iter_core_type cts
- ) list
- | Ttype_record list ->
- List.iter (fun (s, _, mut, ct, loc) ->
- iter_core_type ct
- ) list
- end;
- begin match decl.typ_manifest with
- None -> ()
- | Some ct -> iter_core_type ct
- end;
- Iter.leave_type_declaration decl
-
- and iter_exception_declaration decl =
- Iter.enter_exception_declaration decl;
- List.iter iter_core_type decl.exn_params;
- Iter.leave_exception_declaration decl;
-
- and iter_pattern pat =
- Iter.enter_pattern pat;
- List.iter (fun (cstr, _) -> match cstr with
- | Tpat_type _ -> ()
- | Tpat_unpack -> ()
- | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
- begin
- match pat.pat_desc with
- Tpat_any -> ()
- | Tpat_var (id, _) -> ()
- | Tpat_alias (pat1, _, _) -> iter_pattern pat1
- | Tpat_constant cst -> ()
- | Tpat_tuple list ->
- List.iter iter_pattern list
- | Tpat_construct (path, _, _, args, _) ->
- List.iter iter_pattern args
- | Tpat_variant (label, pato, _) ->
- begin match pato with
- None -> ()
- | Some pat -> iter_pattern pat
- end
- | Tpat_record (list, closed) ->
- List.iter (fun (path, _, _, pat) -> iter_pattern pat) list
- | Tpat_array list -> List.iter iter_pattern list
- | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
- | Tpat_lazy p -> iter_pattern p
- end;
- Iter.leave_pattern pat
-
- and option f x = match x with None -> () | Some e -> f e
-
- and iter_expression exp =
- Iter.enter_expression exp;
- List.iter (function (cstr, _) ->
- match cstr with
- Texp_constraint (cty1, cty2) ->
- option iter_core_type cty1; option iter_core_type cty2
- | Texp_open (path, _, _) -> ()
- | Texp_poly cto -> option iter_core_type cto
- | Texp_newtype s -> ())
- exp.exp_extra;
- begin
- match exp.exp_desc with
- Texp_ident (path, _, _) -> ()
- | Texp_constant cst -> ()
- | Texp_let (rec_flag, list, exp) ->
- iter_bindings rec_flag list;
- iter_expression exp
- | Texp_function (label, cases, _) ->
- iter_bindings Nonrecursive cases
- | Texp_apply (exp, list) ->
- iter_expression exp;
- List.iter (fun (label, expo, _) ->
- match expo with
- None -> ()
- | Some exp -> iter_expression exp
- ) list
- | Texp_match (exp, list, _) ->
- iter_expression exp;
- iter_bindings Nonrecursive list
- | Texp_try (exp, list) ->
- iter_expression exp;
- iter_bindings Nonrecursive list
- | Texp_tuple list ->
- List.iter iter_expression list
- | Texp_construct (path, _, _, args, _) ->
- List.iter iter_expression args
- | Texp_variant (label, expo) ->
- begin match expo with
- None -> ()
- | Some exp -> iter_expression exp
- end
- | Texp_record (list, expo) ->
- List.iter (fun (path, _, _, exp) ->
- iter_expression exp
- ) list;
- begin match expo with
- None -> ()
- | Some exp -> iter_expression exp
- end
- | Texp_field (exp, path, _, label) ->
- iter_expression exp
- | Texp_setfield (exp1, path, _ , label, exp2) ->
- iter_expression exp1;
- iter_expression exp2
- | Texp_array list ->
- List.iter iter_expression list
- | Texp_ifthenelse (exp1, exp2, expo) ->
- iter_expression exp1;
- iter_expression exp2;
- begin match expo with
- None -> ()
- | Some exp -> iter_expression exp
- end
- | Texp_sequence (exp1, exp2) ->
- iter_expression exp1;
- iter_expression exp2
- | Texp_while (exp1, exp2) ->
- iter_expression exp1;
- iter_expression exp2
- | Texp_for (id, _, exp1, exp2, dir, exp3) ->
- iter_expression exp1;
- iter_expression exp2;
- iter_expression exp3
- | Texp_when (exp1, exp2) ->
- iter_expression exp1;
- iter_expression exp2
- | Texp_send (exp, meth, expo) ->
- iter_expression exp;
- begin
- match expo with
- None -> ()
- | Some exp -> iter_expression exp
- end
- | Texp_new (path, _, _) -> ()
- | Texp_instvar (_, path, _) -> ()
- | Texp_setinstvar (_, _, _, exp) ->
- iter_expression exp
- | Texp_override (_, list) ->
- List.iter (fun (path, _, exp) ->
- iter_expression exp
- ) list
- | Texp_letmodule (id, _, mexpr, exp) ->
- iter_module_expr mexpr;
- iter_expression exp
- | Texp_assert exp -> iter_expression exp
- | Texp_assertfalse -> ()
- | Texp_lazy exp -> iter_expression exp
- | Texp_object (cl, _) ->
- iter_class_structure cl
- | Texp_pack (mexpr) ->
- iter_module_expr mexpr
- end;
- Iter.leave_expression exp;
-
- and iter_package_type pack =
- Iter.enter_package_type pack;
- List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields;
- Iter.leave_package_type pack;
-
- and iter_signature sg =
- Iter.enter_signature sg;
- List.iter iter_signature_item sg.sig_items;
- Iter.leave_signature sg;
-
- and iter_signature_item item =
- Iter.enter_signature_item item;
- begin
- match item.sig_desc with
- Tsig_value (id, _, v) ->
- iter_value_description v
- | Tsig_type list ->
- List.iter (fun (id, _, decl) ->
- iter_type_declaration decl
- ) list
- | Tsig_exception (id, _, decl) ->
- iter_exception_declaration decl
- | Tsig_module (id, _, mtype) ->
- iter_module_type mtype
- | Tsig_recmodule list ->
- List.iter (fun (id, _, mtype) -> iter_module_type mtype) list
- | Tsig_modtype (id, _, mdecl) ->
- iter_modtype_declaration mdecl
- | Tsig_open _ -> ()
- | Tsig_include (mty,_) -> iter_module_type mty
- | Tsig_class list ->
- List.iter iter_class_description list
- | Tsig_class_type list ->
- List.iter iter_class_type_declaration list
- end;
- Iter.leave_signature_item item;
-
- and iter_modtype_declaration mdecl =
- Iter.enter_modtype_declaration mdecl;
- begin
- match mdecl with
- Tmodtype_abstract -> ()
- | Tmodtype_manifest mtype -> iter_module_type mtype
- end;
- Iter.leave_modtype_declaration mdecl;
-
-
- and iter_class_description cd =
- Iter.enter_class_description cd;
- iter_class_type cd.ci_expr;
- Iter.leave_class_description cd;
-
- and iter_class_type_declaration cd =
- Iter.enter_class_type_declaration cd;
- iter_class_type cd.ci_expr;
- Iter.leave_class_type_declaration cd;
-
- and iter_module_type mty =
- Iter.enter_module_type mty;
- begin
- match mty.mty_desc with
- Tmty_ident (path, _) -> ()
- | Tmty_signature sg -> iter_signature sg
- | Tmty_functor (id, _, mtype1, mtype2) ->
- iter_module_type mtype1; iter_module_type mtype2
- | Tmty_with (mtype, list) ->
- iter_module_type mtype;
- List.iter (fun (path, _, withc) ->
- iter_with_constraint withc
- ) list
- | Tmty_typeof mexpr ->
- iter_module_expr mexpr
- end;
- Iter.leave_module_type mty;
-
- and iter_with_constraint cstr =
- Iter.enter_with_constraint cstr;
- begin
- match cstr with
- Twith_type decl -> iter_type_declaration decl
- | Twith_module _ -> ()
- | Twith_typesubst decl -> iter_type_declaration decl
- | Twith_modsubst _ -> ()
- end;
- Iter.leave_with_constraint cstr;
-
- and iter_module_expr mexpr =
- Iter.enter_module_expr mexpr;
- begin
- match mexpr.mod_desc with
- Tmod_ident (p, _) -> ()
- | Tmod_structure st -> iter_structure st
- | Tmod_functor (id, _, mtype, mexpr) ->
- iter_module_type mtype;
- iter_module_expr mexpr
- | Tmod_apply (mexp1, mexp2, _) ->
- iter_module_expr mexp1;
- iter_module_expr mexp2
- | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
- iter_module_expr mexpr
- | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
- iter_module_expr mexpr;
- iter_module_type mtype
- | Tmod_unpack (exp, mty) ->
- iter_expression exp
-(* iter_module_type mty *)
- end;
- Iter.leave_module_expr mexpr;
-
- and iter_class_expr cexpr =
- Iter.enter_class_expr cexpr;
- begin
- match cexpr.cl_desc with
- | Tcl_constraint (cl, None, _, _, _ ) ->
- iter_class_expr cl;
- | Tcl_structure clstr -> iter_class_structure clstr
- | Tcl_fun (label, pat, priv, cl, partial) ->
- iter_pattern pat;
- List.iter (fun (id, _, exp) -> iter_expression exp) priv;
- iter_class_expr cl
-
- | Tcl_apply (cl, args) ->
- iter_class_expr cl;
- List.iter (fun (label, expo, _) ->
- match expo with
- None -> ()
- | Some exp -> iter_expression exp
- ) args
-
- | Tcl_let (rec_flat, bindings, ivars, cl) ->
- iter_bindings rec_flat bindings;
- List.iter (fun (id, _, exp) -> iter_expression exp) ivars;
- iter_class_expr cl
-
- | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
- iter_class_expr cl;
- iter_class_type clty
-
- | Tcl_ident (_, _, tyl) ->
- List.iter iter_core_type tyl
- end;
- Iter.leave_class_expr cexpr;
-
- and iter_class_type ct =
- Iter.enter_class_type ct;
- begin
- match ct.cltyp_desc with
- Tcty_signature csg -> iter_class_signature csg
- | Tcty_constr (path, _, list) ->
- List.iter iter_core_type list
- | Tcty_fun (label, ct, cl) ->
- iter_core_type ct;
- iter_class_type cl
- end;
- Iter.leave_class_type ct;
-
- and iter_class_signature cs =
- Iter.enter_class_signature cs;
- iter_core_type cs.csig_self;
- List.iter iter_class_type_field cs.csig_fields;
- Iter.leave_class_signature cs
-
-
- and iter_class_type_field ctf =
- Iter.enter_class_type_field ctf;
- begin
- match ctf.ctf_desc with
- Tctf_inher ct -> iter_class_type ct
- | Tctf_val (s, mut, virt, ct) ->
- iter_core_type ct
- | Tctf_virt (s, priv, ct) ->
- iter_core_type ct
- | Tctf_meth (s, priv, ct) ->
- iter_core_type ct
- | Tctf_cstr (ct1, ct2) ->
- iter_core_type ct1;
- iter_core_type ct2
- end;
- Iter.leave_class_type_field ctf
-
- and iter_core_type ct =
- Iter.enter_core_type ct;
- begin
- match ct.ctyp_desc with
- Ttyp_any -> ()
- | Ttyp_var s -> ()
- | Ttyp_arrow (label, ct1, ct2) ->
- iter_core_type ct1;
- iter_core_type ct2
- | Ttyp_tuple list -> List.iter iter_core_type list
- | Ttyp_constr (path, _, list) ->
- List.iter iter_core_type list
- | Ttyp_object list ->
- List.iter iter_core_field_type list
- | Ttyp_class (path, _, list, labels) ->
- List.iter iter_core_type list
- | Ttyp_alias (ct, s) ->
- iter_core_type ct
- | Ttyp_variant (list, bool, labels) ->
- List.iter iter_row_field list
- | Ttyp_poly (list, ct) -> iter_core_type ct
- | Ttyp_package pack -> iter_package_type pack
- end;
- Iter.leave_core_type ct;
-
- and iter_core_field_type cft =
- Iter.enter_core_field_type cft;
- begin match cft.field_desc with
- Tcfield_var -> ()
- | Tcfield (s, ct) -> iter_core_type ct
- end;
- Iter.leave_core_field_type cft;
-
- and iter_class_structure cs =
- Iter.enter_class_structure cs;
- iter_pattern cs.cstr_pat;
- List.iter iter_class_field cs.cstr_fields;
- Iter.leave_class_structure cs;
-
-
- and iter_row_field rf =
- match rf with
- Ttag (label, bool, list) ->
- List.iter iter_core_type list
- | Tinherit ct -> iter_core_type ct
-
- and iter_class_field cf =
- Iter.enter_class_field cf;
- begin
- match cf.cf_desc with
- Tcf_inher (ovf, cl, super, _vals, _meths) ->
- iter_class_expr cl
- | Tcf_constr (cty, cty') ->
- iter_core_type cty;
- iter_core_type cty'
- | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
- iter_core_type cty
- | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
- iter_expression exp
- | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
- iter_core_type cty
- | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
- iter_expression exp
-(* | Tcf_let (rec_flag, bindings, exps) ->
- iter_bindings rec_flag bindings;
- List.iter (fun (id, _, exp) -> iter_expression exp) exps; *)
- | Tcf_init exp ->
- iter_expression exp
- end;
- Iter.leave_class_field cf;
-
- end
-
-module DefaultIteratorArgument = struct
-
- let enter_structure _ = ()
- let enter_value_description _ = ()
- let enter_type_declaration _ = ()
- let enter_exception_declaration _ = ()
- let enter_pattern _ = ()
- let enter_expression _ = ()
- let enter_package_type _ = ()
- let enter_signature _ = ()
- let enter_signature_item _ = ()
- let enter_modtype_declaration _ = ()
- let enter_module_type _ = ()
- let enter_module_expr _ = ()
- let enter_with_constraint _ = ()
- let enter_class_expr _ = ()
- let enter_class_signature _ = ()
- let enter_class_declaration _ = ()
- let enter_class_description _ = ()
- let enter_class_type_declaration _ = ()
- let enter_class_type _ = ()
- let enter_class_type_field _ = ()
- let enter_core_type _ = ()
- let enter_core_field_type _ = ()
- let enter_class_structure _ = ()
- let enter_class_field _ = ()
- let enter_structure_item _ = ()
-
-
- let leave_structure _ = ()
- let leave_value_description _ = ()
- let leave_type_declaration _ = ()
- let leave_exception_declaration _ = ()
- let leave_pattern _ = ()
- let leave_expression _ = ()
- let leave_package_type _ = ()
- let leave_signature _ = ()
- let leave_signature_item _ = ()
- let leave_modtype_declaration _ = ()
- let leave_module_type _ = ()
- let leave_module_expr _ = ()
- let leave_with_constraint _ = ()
- let leave_class_expr _ = ()
- let leave_class_signature _ = ()
- let leave_class_declaration _ = ()
- let leave_class_description _ = ()
- let leave_class_type_declaration _ = ()
- let leave_class_type _ = ()
- let leave_class_type_field _ = ()
- let leave_core_type _ = ()
- let leave_core_field_type _ = ()
- let leave_class_structure _ = ()
- let leave_class_field _ = ()
- let leave_structure_item _ = ()
-
- let enter_binding _ _ = ()
- let leave_binding _ _ = ()
-
- let enter_bindings _ = ()
- let leave_bindings _ = ()
-
- end
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(**************************************************************************)
-
-open Asttypes
-open Typedtree
-
-
-module type IteratorArgument = sig
- val enter_structure : structure -> unit
- val enter_value_description : value_description -> unit
- val enter_type_declaration : type_declaration -> unit
- val enter_exception_declaration :
- exception_declaration -> unit
- val enter_pattern : pattern -> unit
- val enter_expression : expression -> unit
- val enter_package_type : package_type -> unit
- val enter_signature : signature -> unit
- val enter_signature_item : signature_item -> unit
- val enter_modtype_declaration : modtype_declaration -> unit
- val enter_module_type : module_type -> unit
- val enter_module_expr : module_expr -> unit
- val enter_with_constraint : with_constraint -> unit
- val enter_class_expr : class_expr -> unit
- val enter_class_signature : class_signature -> unit
- val enter_class_declaration : class_declaration -> unit
- val enter_class_description : class_description -> unit
- val enter_class_type_declaration : class_type_declaration -> unit
- val enter_class_type : class_type -> unit
- val enter_class_type_field : class_type_field -> unit
- val enter_core_type : core_type -> unit
- val enter_core_field_type : core_field_type -> unit
- val enter_class_structure : class_structure -> unit
- val enter_class_field : class_field -> unit
- val enter_structure_item : structure_item -> unit
-
-
- val leave_structure : structure -> unit
- val leave_value_description : value_description -> unit
- val leave_type_declaration : type_declaration -> unit
- val leave_exception_declaration :
- exception_declaration -> unit
- val leave_pattern : pattern -> unit
- val leave_expression : expression -> unit
- val leave_package_type : package_type -> unit
- val leave_signature : signature -> unit
- val leave_signature_item : signature_item -> unit
- val leave_modtype_declaration : modtype_declaration -> unit
- val leave_module_type : module_type -> unit
- val leave_module_expr : module_expr -> unit
- val leave_with_constraint : with_constraint -> unit
- val leave_class_expr : class_expr -> unit
- val leave_class_signature : class_signature -> unit
- val leave_class_declaration : class_declaration -> unit
- val leave_class_description : class_description -> unit
- val leave_class_type_declaration : class_type_declaration -> unit
- val leave_class_type : class_type -> unit
- val leave_class_type_field : class_type_field -> unit
- val leave_core_type : core_type -> unit
- val leave_core_field_type : core_field_type -> unit
- val leave_class_structure : class_structure -> unit
- val leave_class_field : class_field -> unit
- val leave_structure_item : structure_item -> unit
-
- val enter_bindings : rec_flag -> unit
- val enter_binding : pattern -> expression -> unit
- val leave_binding : pattern -> expression -> unit
- val leave_bindings : rec_flag -> unit
-
- end
-
-module MakeIterator :
- functor
- (Iter : IteratorArgument) ->
- sig
- val iter_structure : structure -> unit
- val iter_signature : signature -> unit
- val iter_structure_item : structure_item -> unit
- val iter_signature_item : signature_item -> unit
- val iter_expression : expression -> unit
- val iter_module_type : module_type -> unit
- val iter_pattern : pattern -> unit
- val iter_class_expr : class_expr -> unit
- end
-
-module DefaultIteratorArgument : IteratorArgument
(* *)
(**************************************************************************)
-open Misc
open Asttypes
open Typedtree
open Parsetree
| Tstr_value (rec_flag, list) ->
Pstr_value (rec_flag, List.map (fun (pat, exp) ->
untype_pattern pat, untype_expression exp) list)
- | Tstr_primitive (id, name, v) ->
+ | Tstr_primitive (_id, name, v) ->
Pstr_primitive (name, untype_value_description v)
| Tstr_type list ->
- Pstr_type (List.map (fun (id, name, decl) ->
+ Pstr_type (List.map (fun (_id, name, decl) ->
name, untype_type_declaration decl) list)
- | Tstr_exception (id, name, decl) ->
+ | Tstr_exception (_id, name, decl) ->
Pstr_exception (name, untype_exception_declaration decl)
- | Tstr_exn_rebind (id, name, p, lid) ->
+ | Tstr_exn_rebind (_id, name, _p, lid) ->
Pstr_exn_rebind (name, lid)
- | Tstr_module (id, name, mexpr) ->
+ | Tstr_module (_id, name, mexpr) ->
Pstr_module (name, untype_module_expr mexpr)
| Tstr_recmodule list ->
- Pstr_recmodule (List.map (fun (id, name, mtype, mexpr) ->
+ Pstr_recmodule (List.map (fun (_id, name, mtype, mexpr) ->
name, untype_module_type mtype,
untype_module_expr mexpr) list)
- | Tstr_modtype (id, name, mtype) ->
+ | Tstr_modtype (_id, name, mtype) ->
Pstr_modtype (name, untype_module_type mtype)
- | Tstr_open (path, lid) -> Pstr_open (lid)
+ | Tstr_open (ovf, _path, lid) -> Pstr_open (ovf, lid)
| Tstr_class list ->
Pstr_class (List.map (fun (ci, _, _) ->
{ pci_virt = ci.ci_virt;
}
) list)
| Tstr_class_type list ->
- Pstr_class_type (List.map (fun (id, name, ct) ->
+ Pstr_class_type (List.map (fun (_id, _name, ct) ->
{
pci_virt = ct.ci_virt;
pci_params = ct.ci_params;
ptype_kind = (match decl.typ_kind with
Ttype_abstract -> Ptype_abstract
| Ttype_variant list ->
- Ptype_variant (List.map (fun (s, name, cts, loc) ->
+ Ptype_variant (List.map (fun (_s, name, cts, loc) ->
(name, List.map untype_core_type cts, None, loc)
) list)
| Ttype_record list ->
- Ptype_record (List.map (fun (s, name, mut, ct, loc) ->
+ Ptype_record (List.map (fun (_s, name, mut, ct, loc) ->
(name, mut, untype_core_type ct, loc)
) list)
);
and untype_pattern pat =
let desc =
match pat with
- { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name) } -> Ppat_unpack name
- | { pat_extra=[Tpat_type (path, lid), _] } -> Ppat_type lid
- | { pat_extra= (Tpat_constraint ct, _) :: rem } ->
- Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct)
+ { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name); _ } ->
+ Ppat_unpack name
+ | { pat_extra=[Tpat_type (_path, lid), _]; _ } -> Ppat_type lid
+ | { pat_extra= (Tpat_constraint ct, _) :: rem; _ } ->
+ Ppat_constraint (untype_pattern { pat with pat_extra=rem },
+ untype_core_type ct)
| _ ->
match pat.pat_desc with
Tpat_any -> Ppat_any
| _ ->
Ppat_var name
end
- | Tpat_alias (pat, id, name) ->
+ | Tpat_alias (pat, _id, name) ->
Ppat_alias (untype_pattern pat, name)
| Tpat_constant cst -> Ppat_constant cst
| Tpat_tuple list ->
Ppat_tuple (List.map untype_pattern list)
- | Tpat_construct (path, lid, _, args, explicit_arity) ->
+ | Tpat_construct (lid, _, args, explicit_arity) ->
Ppat_construct (lid,
(match args with
[] -> None
+ | [arg] -> Some (untype_pattern arg)
| args -> Some
{ ppat_desc = Ppat_tuple (List.map untype_pattern args);
ppat_loc = pat.pat_loc; }
None -> None
| Some pat -> Some (untype_pattern pat))
| Tpat_record (list, closed) ->
- Ppat_record (List.map (fun (path, lid, _, pat) ->
+ Ppat_record (List.map (fun (lid, _, pat) ->
lid, untype_pattern pat) list, closed)
| Tpat_array list -> Ppat_array (List.map untype_pattern list)
| Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
Pexp_constraint (sexp,
option untype_core_type cty1,
option untype_core_type cty2)
- | Texp_open (path, lid, _) -> Pexp_open (lid, sexp)
+ | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, lid, sexp)
| Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto)
| Texp_newtype s -> Pexp_newtype (s, sexp)
in
and untype_expression exp =
let desc =
match exp.exp_desc with
- Texp_ident (path, lid, _) -> Pexp_ident (lid)
+ Texp_ident (_path, lid, _) -> Pexp_ident (lid)
| Texp_constant cst -> Pexp_constant cst
| Texp_let (rec_flag, list, exp) ->
Pexp_let (rec_flag,
untype_pattern pat, untype_expression exp) list)
| Texp_tuple list ->
Pexp_tuple (List.map untype_expression list)
- | Texp_construct (path, lid, _, args, explicit_arity) ->
+ | Texp_construct (lid, _, args, explicit_arity) ->
Pexp_construct (lid,
(match args with
[] -> None
None -> None
| Some exp -> Some (untype_expression exp))
| Texp_record (list, expo) ->
- Pexp_record (List.map (fun (path, lid, _, exp) ->
+ Pexp_record (List.map (fun (lid, _, exp) ->
lid, untype_expression exp
) list,
match expo with
None -> None
| Some exp -> Some (untype_expression exp))
- | Texp_field (exp, path, lid, label) ->
+ | Texp_field (exp, lid, _label) ->
Pexp_field (untype_expression exp, lid)
- | Texp_setfield (exp1, path, lid, label, exp2) ->
+ | Texp_setfield (exp1, lid, _label, exp2) ->
Pexp_setfield (untype_expression exp1, lid,
untype_expression exp2)
| Texp_array list ->
Pexp_sequence (untype_expression exp1, untype_expression exp2)
| Texp_while (exp1, exp2) ->
Pexp_while (untype_expression exp1, untype_expression exp2)
- | Texp_for (id, name, exp1, exp2, dir, exp3) ->
+ | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
Pexp_for (name,
untype_expression exp1, untype_expression exp2,
dir, untype_expression exp3)
Pexp_send (untype_expression exp, match meth with
Tmeth_name name -> name
| Tmeth_val id -> Ident.name id)
- | Texp_new (path, lid, _) -> Pexp_new (lid)
+ | Texp_new (_path, lid, _) -> Pexp_new (lid)
| Texp_instvar (_, path, name) ->
Pexp_ident ({name with txt = lident_of_path path})
- | Texp_setinstvar (_, path, lid, exp) ->
+ | Texp_setinstvar (_, _path, lid, exp) ->
Pexp_setinstvar (lid, untype_expression exp)
| Texp_override (_, list) ->
- Pexp_override (List.map (fun (path, lid, exp) ->
+ Pexp_override (List.map (fun (_path, lid, exp) ->
lid, untype_expression exp
) list)
- | Texp_letmodule (id, name, mexpr, exp) ->
+ | Texp_letmodule (_id, name, mexpr, exp) ->
Pexp_letmodule (name, untype_module_expr mexpr,
untype_expression exp)
| Texp_assert exp -> Pexp_assert (untype_expression exp)
and untype_signature_item item =
let desc =
match item.sig_desc with
- Tsig_value (id, name, v) ->
+ Tsig_value (_id, name, v) ->
Psig_value (name, untype_value_description v)
| Tsig_type list ->
- Psig_type (List.map (fun (id, name, decl) ->
+ Psig_type (List.map (fun (_id, name, decl) ->
name, untype_type_declaration decl
) list)
- | Tsig_exception (id, name, decl) ->
+ | Tsig_exception (_id, name, decl) ->
Psig_exception (name, untype_exception_declaration decl)
- | Tsig_module (id, name, mtype) ->
+ | Tsig_module (_id, name, mtype) ->
Psig_module (name, untype_module_type mtype)
| Tsig_recmodule list ->
- Psig_recmodule (List.map (fun (id, name, mtype) ->
+ Psig_recmodule (List.map (fun (_id, name, mtype) ->
name, untype_module_type mtype) list)
- | Tsig_modtype (id, name, mdecl) ->
+ | Tsig_modtype (_id, name, mdecl) ->
Psig_modtype (name, untype_modtype_declaration mdecl)
- | Tsig_open (path, lid) -> Psig_open (lid)
- | Tsig_include (mty, lid) -> Psig_include (untype_module_type mty)
+ | Tsig_open (ovf, _path, lid) -> Psig_open (ovf, lid)
+ | Tsig_include (mty, _) -> Psig_include (untype_module_type mty)
| Tsig_class list ->
Psig_class (List.map untype_class_description list)
| Tsig_class_type list ->
and untype_module_type mty =
let desc = match mty.mty_desc with
- Tmty_ident (path, lid) -> Pmty_ident (lid)
+ Tmty_ident (_path, lid) -> Pmty_ident (lid)
| Tmty_signature sg -> Pmty_signature (untype_signature sg)
- | Tmty_functor (id, name, mtype1, mtype2) ->
+ | Tmty_functor (_id, name, mtype1, mtype2) ->
Pmty_functor (name, untype_module_type mtype1,
untype_module_type mtype2)
| Tmty_with (mtype, list) ->
Pmty_with (untype_module_type mtype,
- List.map (fun (path, lid, withc) ->
+ List.map (fun (_path, lid, withc) ->
lid, untype_with_constraint withc
) list)
| Tmty_typeof mexpr ->
and untype_with_constraint cstr =
match cstr with
Twith_type decl -> Pwith_type (untype_type_declaration decl)
- | Twith_module (path, lid) -> Pwith_module (lid)
+ | Twith_module (_path, lid) -> Pwith_module (lid)
| Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl)
- | Twith_modsubst (path, lid) -> Pwith_modsubst (lid)
+ | Twith_modsubst (_path, lid) -> Pwith_modsubst (lid)
and untype_module_expr mexpr =
match mexpr.mod_desc with
untype_module_expr m
| _ ->
let desc = match mexpr.mod_desc with
- Tmod_ident (p, lid) -> Pmod_ident (lid)
+ Tmod_ident (_p, lid) -> Pmod_ident (lid)
| Tmod_structure st -> Pmod_structure (untype_structure st)
- | Tmod_functor (id, name, mtype, mexpr) ->
+ | Tmod_functor (_id, name, mtype, mexpr) ->
Pmod_functor (name, untype_module_type mtype,
untype_module_expr mexpr)
| Tmod_apply (mexp1, mexp2, _) ->
| Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
Pmod_constraint (untype_module_expr mexpr,
untype_module_type mtype)
- | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) ->
+ | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
assert false
- | Tmod_unpack (exp, pack) ->
+ | Tmod_unpack (exp, _pack) ->
Pmod_unpack (untype_expression exp)
(* TODO , untype_package_type pack) *)
and untype_class_expr cexpr =
let desc = match cexpr.cl_desc with
- | Tcl_constraint ( { cl_desc = Tcl_ident (path, lid, tyl) }, None, _, _, _ ) ->
+ | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+ None, _, _, _ ) ->
Pcl_constr (lid,
List.map untype_core_type tyl)
| Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr)
- | Tcl_fun (label, pat, pv, cl, partial) ->
+ | Tcl_fun (label, pat, _pv, cl, _partial) ->
Pcl_fun (label, None, untype_pattern pat, untype_class_expr cl)
| Tcl_apply (cl, args) ->
| Some exp -> (label, untype_expression exp) :: list
) args [])
- | Tcl_let (rec_flat, bindings, ivars, cl) ->
+ | Tcl_let (rec_flat, bindings, _ivars, cl) ->
Pcl_let (rec_flat,
List.map (fun (pat, exp) ->
(untype_pattern pat, untype_expression exp)) bindings,
untype_class_expr cl)
- | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+ | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
Pcl_constraint (untype_class_expr cl, untype_class_type clty)
| Tcl_ident _ -> assert false
and untype_class_type ct =
let desc = match ct.cltyp_desc with
Tcty_signature csg -> Pcty_signature (untype_class_signature csg)
- | Tcty_constr (path, lid, list) ->
+ | Tcty_constr (_path, lid, list) ->
Pcty_constr (lid, List.map untype_core_type list)
| Tcty_fun (label, ct, cl) ->
Pcty_fun (label, untype_core_type ct, untype_class_type cl)
| Ttyp_arrow (label, ct1, ct2) ->
Ptyp_arrow (label, untype_core_type ct1, untype_core_type ct2)
| Ttyp_tuple list -> Ptyp_tuple (List.map untype_core_type list)
- | Ttyp_constr (path, lid, list) ->
+ | Ttyp_constr (_path, lid, list) ->
Ptyp_constr (lid,
List.map untype_core_type list)
| Ttyp_object list ->
Ptyp_object (List.map untype_core_field_type list)
- | Ttyp_class (path, lid, list, labels) ->
+ | Ttyp_class (_path, lid, list, labels) ->
Ptyp_class (lid,
List.map untype_core_type list, labels)
| Ttyp_alias (ct, s) ->
Pcf_inher (ovf, untype_class_expr cl, super)
| Tcf_constr (cty, cty') ->
Pcf_constr (untype_core_type cty, untype_core_type cty')
- | Tcf_val (lab, name, mut, _, Tcfk_virtual cty, override) ->
+ | Tcf_val (_lab, name, mut, _, Tcfk_virtual cty, _override) ->
Pcf_valvirt (name, mut, untype_core_type cty)
- | Tcf_val (lab, name, mut, _, Tcfk_concrete exp, override) ->
+ | Tcf_val (_lab, name, mut, _, Tcfk_concrete exp, override) ->
Pcf_val (name, mut,
(if override then Override else Fresh),
untype_expression exp)
- | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
+ | Tcf_meth (_lab, name, priv, Tcfk_virtual cty, _override) ->
Pcf_virt (name, priv, untype_core_type cty)
- | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
+ | Tcf_meth (_lab, name, priv, Tcfk_concrete exp, override) ->
Pcf_meth (name, priv,
(if override then Override else Fresh),
untype_expression exp)
val untype_structure : Typedtree.structure -> Parsetree.structure
val untype_signature : Typedtree.signature -> Parsetree.signature
+val untype_expression : Typedtree.expression -> Parsetree.expression
val lident_of_path : Path.t -> Longident.t
(* *)
(***********************************************************************)
-(* $Id: expunge.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* "Expunge" a toplevel by removing compiler modules from the global List.map.
Usage: expunge <source file> <dest file> <names of modules to keep> *)
-open Sys
open Misc
module StringSet =
(* *)
(***********************************************************************)
-(* $Id: genprintval.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* To print values *)
open Misc
let tree_of_constr =
tree_of_qualified
- (fun lid env -> (snd (Env.lookup_constructor lid env)).cstr_res)
+ (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
and tree_of_label =
- tree_of_qualified (fun lid env -> (snd (Env.lookup_label lid env)).lbl_res)
+ tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
(* An abstract type *)
ty_list
with
Ctype.Cannot_apply -> abstract_type in
- let lid = tree_of_label env path (Ident.name lbl_name) in
- let v =
+ let name = Ident.name lbl_name in
+ (* PR#5722: print full module path only
+ for first record field *)
+ let lid =
+ if pos = 0 then tree_of_label env path name
+ else Oide_ident name
+ and v =
tree_of_val (depth - 1) (O.field obj pos)
ty_arg
in
try
(* Attempt to recover the constructor description for the exn
from its name *)
- let cstr = snd (Env.lookup_constructor lid env) in
+ let cstr = Env.lookup_constructor lid env in
let path =
match cstr.cstr_tag with
Cstr_exception (p, _) -> p | _ -> raise Not_found in
(* *)
(***********************************************************************)
-(* $Id: genprintval.mli 12689 2012-07-10 14:54:19Z doligez $ *)
-
(* Printing of values *)
open Types
(* *)
(***********************************************************************)
-(* $Id: opttopdirs.ml 12058 2012-01-20 14:23:34Z frisch $ *)
-
(* Toplevel directives *)
open Format
open Misc
open Longident
-open Path
open Types
open Opttoploop
(* *)
(***********************************************************************)
-(* $Id: opttopdirs.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The toplevel directives. *)
open Format
(* *)
(***********************************************************************)
-(* $Id: opttoploop.ml 12085 2012-01-27 12:48:15Z doligez $ *)
-
(* The interactive toplevel loop *)
open Path
-open Lexing
open Format
open Config
open Misc
open Types
open Typedtree
open Outcometree
-open Lambda
type res = Ok of Obj.t | Err of string
type evaluation_outcome = Result of Obj.t | Exception of exn
+let _dummy = (Ok (Obj.magic 0), Err "")
+
external ndl_run_toplevel: string -> string -> res
= "caml_natdynlink_run_toplevel"
external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym"
with _ -> true
let dll_run dll entry =
- match (try Result (Obj.magic (ndl_run_toplevel dll entry)) with exn -> Exception exn) with
+ match (try Result (Obj.magic (ndl_run_toplevel dll entry))
+ with exn -> Exception exn)
+ with
| Exception _ as r -> r
| Result r ->
match Obj.magic r with
(* To print values *)
module EvalPath = struct
- type value = Obj.t
+ type valu = Obj.t
exception Error
let eval_path p = try eval_path p with _ -> raise Error
let same_value v1 v2 = (v1 == v2)
let phrase_seqid = ref 0
let phrase_name = ref "TOP"
-open Lambda
-
let load_lambda ppf (size, lam) =
if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
let slam = Simplif.simplify_lambda lam in
(* Print the outcome of an evaluation *)
let rec pr_item env = function
- | Tsig_value(id, decl) :: rem ->
+ | Sig_value(id, decl) :: rem ->
let tree = Printtyp.tree_of_value_description id decl in
let valopt =
match decl.val_kind with
Some v
in
Some (tree, valopt, rem)
- | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) ->
+ | Sig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) ->
pr_item env rem
- | Tsig_type(id, decl, rs) :: rem ->
+ | Sig_type(id, decl, rs) :: rem ->
let tree = Printtyp.tree_of_type_declaration id decl rs in
Some (tree, None, rem)
- | Tsig_exception(id, decl) :: rem ->
+ | Sig_exception(id, decl) :: rem ->
let tree = Printtyp.tree_of_exception_declaration id decl in
Some (tree, None, rem)
- | Tsig_module(id, mty, rs) :: rem ->
+ | Sig_module(id, mty, rs) :: rem ->
let tree = Printtyp.tree_of_module id mty rs in
Some (tree, None, rem)
- | Tsig_modtype(id, decl) :: rem ->
+ | Sig_modtype(id, decl) :: rem ->
let tree = Printtyp.tree_of_modtype_declaration id decl in
Some (tree, None, rem)
- | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
+ | Sig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
let tree = Printtyp.tree_of_class_declaration id decl rs in
Some (tree, None, rem)
- | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+ | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
let tree = Printtyp.tree_of_cltype_declaration id decl rs in
Some (tree, None, rem)
| _ -> None
Typecore.reset_delayed_checks ();
let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
in
+ if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
Typecore.force_delayed_checks ();
let res = Translmod.transl_store_phrases !phrase_name str in
Warnings.check_fatal ();
| Result v ->
Compilenv.record_global_approx_toplevel ();
if print_outcome then
- match str with
- | [Tstr_eval exp] ->
+ match str.str_items with
+ | [ {str_desc = Tstr_eval exp} ] ->
let outv = outval_of_value newenv v exp.exp_type in
let ty = Printtyp.tree_of_type_scheme exp.exp_type in
Ophr_eval (outv, ty)
List.iter
(fun ph ->
if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+ if !Clflags.dump_source then Pprintast.top_phrase ppf ph;
if not (execute_phrase !use_print_results ppf ph) then raise Exit)
(!parse_use_file lb);
true
let _ =
Sys.interactive := true;
Dynlink.init ();
- Optcompile.init_path();
+ Compmisc.init_path true;
Clflags.dlcode := true;
()
()
let initialize_toplevel_env () =
- toplevel_env := Optcompile.initial_env()
+ toplevel_env := Compmisc.initial_env()
(* The interactive loop *)
first_line := true;
let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+ if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
ignore(execute_phrase true ppf phr)
with
| End_of_file -> exit 0
Array.blit args 0 Sys.argv 0 len;
Obj.truncate (Obj.repr Sys.argv) len;
Arg.current := 0;
- Optcompile.init_path();
- toplevel_env := Optcompile.initial_env();
+ Compmisc.init_path true;
+ toplevel_env := Compmisc.initial_env();
Sys.interactive := false;
use_silently ppf name
(* *)
(***********************************************************************)
-(* $Id: opttoploop.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Format
(* Set the load paths, before running anything *)
(* *)
(***********************************************************************)
-(* $Id: opttopmain.ml 12085 2012-01-27 12:48:15Z doligez $ *)
-
open Clflags
-let usage = "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:"
+let usage =
+ "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:"
let preload_objects = ref []
let _noprompt = set noprompt
let _nopromptcont = set nopromptcont
let _nostdlib = set no_std_include
+ let _ppx s = Compenv.first_ppx := s :: !Compenv.first_ppx
let _principal = set principal
+ let _real_paths = set real_paths
let _rectypes = set recursive_types
let _strict_sequence = set strict_sequence
let _S = set keep_asm_file
+ let _short_paths = clear real_paths
let _stdin () = file_argument ""
let _unsafe = set fast
let _version () = print_version ()
let _warn_error s = Warnings.parse_options true s
let _warn_help = Warnings.help_warnings
+ let _dsource = set dump_source
let _dparsetree = set dump_parsetree
+ let _dtypedtree = set dump_typedtree
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
+ let _dclambda = set dump_clambda
let _dcmm = set dump_cmm
let _dsel = set dump_selection
let _dcombine = set dump_combine
(* *)
(***********************************************************************)
-(* $Id: opttopmain.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Start the [ocaml] toplevel loop *)
val main: unit -> unit
(* *)
(***********************************************************************)
-(* $Id: opttopstart.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
let _ = Opttopmain.main()
(* *)
(***********************************************************************)
-(* $Id: topdirs.ml 12661 2012-07-07 11:41:17Z scherer $ *)
-
(* Toplevel directives *)
open Format
open Misc
open Longident
-open Path
open Types
open Cmo_format
open Trace
end
let rec load_file recursive ppf name =
- let filename = try Some (find_in_path !Config.load_path name) with Not_found -> None in
+ let filename =
+ try Some (find_in_path !Config.load_path name) with Not_found -> None
+ in
match filename with
| None -> fprintf ppf "Cannot find file %s.@." name; false
| Some filename ->
if recursive then
List.iter
(function
- | (Reloc_getglobal id, _) when not (Symtable.is_global_defined id) ->
+ | (Reloc_getglobal id, _)
+ when not (Symtable.is_global_defined id) ->
let file = Ident.name id ^ ".cmo" in
- begin match try Some (Misc.find_in_path_uncap !Config.load_path file) with Not_found -> None with
+ begin match try Some (Misc.find_in_path_uncap !Config.load_path
+ file)
+ with Not_found -> None
+ with
| None -> ()
- | Some file -> if not (load_file recursive ppf file) then raise Load_failed
+ | Some file ->
+ if not (load_file recursive ppf file) then raise Load_failed
end
| _ -> ()
)
let dir_load_rec ppf name = ignore (load_file true ppf name)
-let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out))
+let _ = Hashtbl.add directive_table "load_rec"
+ (Directive_string (dir_load_rec std_out))
let load_file = load_file false
(* Load commands from a file *)
let dir_use ppf name = ignore(Toploop.use_file ppf name)
+let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name)
let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out))
+let _ = Hashtbl.add directive_table "mod_use"
+ (Directive_string (dir_mod_use std_out))
(* Install, remove a printer *)
(* *)
(***********************************************************************)
-(* $Id: topdirs.mli 12661 2012-07-07 11:41:17Z scherer $ *)
-
(* The toplevel directives. *)
open Format
(* *)
(***********************************************************************)
-(* $Id: toploop.ml 12689 2012-07-10 14:54:19Z doligez $ *)
-
(* The interactive toplevel loop *)
open Path
-open Lexing
open Format
open Config
open Misc
let print_warning = Location.print_warning
let input_name = Location.input_name
+let parse_mod_use_file name lb =
+ let modname =
+ String.capitalize (Filename.chop_extension (Filename.basename name))
+ in
+ let items =
+ List.concat
+ (List.map
+ (function Ptop_def s -> s | Ptop_dir _ -> [])
+ (!parse_use_file lb))
+ in
+ [ Ptop_def
+ [ { pstr_desc =
+ Pstr_module ( Location.mknoloc modname ,
+ { pmod_desc = Pmod_structure items;
+ pmod_loc = Location.none } );
+ pstr_loc = Location.none } ] ]
+
(* Hooks for initialization *)
let toplevel_startup_hook = ref (fun () -> ())
(* Print the outcome of an evaluation *)
-let rec pr_item env = function
+let rec pr_item env items =
+ Printtyp.hide_rec_items items;
+ match items with
| Sig_value(id, decl) :: rem ->
let tree = Printtyp.tree_of_value_description id decl in
let valopt =
let oldenv = !toplevel_env in
Typecore.reset_delayed_checks ();
let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
+ if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
let sg' = Typemod.simplify_signature sg in
ignore (Includemod.signatures oldenv sg sg');
Typecore.force_delayed_checks ();
match res with
| Result v ->
if print_outcome then
- match str.str_items with
- | [ { str_desc = Tstr_eval exp }] ->
- let outv = outval_of_value newenv v exp.exp_type in
- let ty = Printtyp.tree_of_type_scheme exp.exp_type in
- Ophr_eval (outv, ty)
- | [] -> Ophr_signature []
- | _ -> Ophr_signature (item_list newenv sg')
+ Printtyp.wrap_printing_env oldenv (fun () ->
+ match str.str_items with
+ | [ { str_desc = Tstr_eval exp }] ->
+ let outv = outval_of_value newenv v exp.exp_type in
+ let ty = Printtyp.tree_of_type_scheme exp.exp_type in
+ Ophr_eval (outv, ty)
+ | [] -> Ophr_signature []
+ | _ -> Ophr_signature (item_list newenv sg'))
else Ophr_signature []
| Exception exn ->
toplevel_env := oldenv;
let use_print_results = ref true
-let use_file ppf name =
+let phrase ppf phr =
+ let phr =
+ match phr with
+ | Ptop_def str ->
+ Ptop_def (Pparse.apply_rewriters ast_impl_magic_number str)
+ | phr -> phr
+ in
+ if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+ if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+ phr
+
+let use_file ppf wrap_mod name =
try
let (filename, ic, must_close) =
if name = "" then
try
List.iter
(fun ph ->
- if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+ let ph = phrase ppf ph in
if not (execute_phrase !use_print_results ppf ph) then raise Exit)
- (!parse_use_file lb);
+ (if wrap_mod then
+ parse_mod_use_file name lb
+ else
+ !parse_use_file lb);
true
with
| Exit -> false
success
with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
+let mod_use_file ppf name = use_file ppf true name
+let use_file ppf name = use_file ppf false name
+
let use_silently ppf name =
protect use_print_results false (fun () -> use_file ppf name)
let _ =
Sys.interactive := true;
let crc_intfs = Symtable.init_toplevel() in
- Compile.init_path();
+ Compmisc.init_path false;
List.iter
(fun (name, crc) ->
Consistbl.set Env.crc_units name crc Sys.executable_name)
Dll.add_path !load_path
let initialize_toplevel_env () =
- toplevel_env := Compile.initial_env()
+ toplevel_env := Compmisc.initial_env()
(* The interactive loop *)
Location.reset();
first_line := true;
let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
- if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
- Env.reset_missing_cmis ();
+ let phr = phrase ppf phr in
+ Env.reset_cache_toplevel ();
ignore(execute_phrase true ppf phr)
with
| End_of_file -> exit 0
Array.blit args 0 Sys.argv 0 len;
Obj.truncate (Obj.repr Sys.argv) len;
Arg.current := 0;
- Compile.init_path();
- toplevel_env := Compile.initial_env();
+ Compmisc.init_path false;
+ toplevel_env := Compmisc.initial_env();
Sys.interactive := false;
use_silently ppf name
(* *)
(***********************************************************************)
-(* $Id: toploop.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Format
(* Accessors for the table of toplevel value bindings. These functions
should be printed. Uncaught exceptions are always printed. *)
val use_file : formatter -> string -> bool
val use_silently : formatter -> string -> bool
+val mod_use_file : formatter -> string -> bool
(* Read and execute commands from a file.
[use_file] prints the types and values of the results.
- [use_silently] does not print them. *)
+ [use_silently] does not print them.
+ [mod_use_file] wrap the file contents into a module. *)
val eval_path: Path.t -> Obj.t
(* Return the toplevel object referred to by the given path *)
(* *)
(***********************************************************************)
-(* $Id: topmain.ml 12085 2012-01-27 12:48:15Z doligez $ *)
-
open Clflags
+open Compenv
let usage = "Usage: ocaml <options> <object-files> [script-file [arguments]]\n\
options are:"
let _noprompt = set noprompt
let _nopromptcont = set nopromptcont
let _nostdlib = set no_std_include
+ let _ppx s = first_ppx := s :: !first_ppx
let _principal = set principal
let _rectypes = set recursive_types
+ let _short_paths = clear real_paths
let _stdin () = file_argument ""
let _strict_sequence = set strict_sequence
let _unsafe = set fast
let _warn_error s = Warnings.parse_options true s
let _warn_help = Warnings.help_warnings
let _dparsetree = set dump_parsetree
+ let _dtypedtree = set dump_typedtree
+ let _dsource = set dump_source
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _dinstr = set dump_instr
let main () =
+ let ppf = Format.err_formatter in
+ Compenv.readenv ppf Before_args;
Arg.parse Options.list file_argument usage;
- if not (prepare Format.err_formatter) then exit 2;
+ Compenv.readenv ppf Before_link;
+ if not (prepare ppf) then exit 2;
Toploop.loop Format.std_formatter
(* *)
(***********************************************************************)
-(* $Id: topmain.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Start the [ocaml] toplevel loop *)
val main: unit -> unit
(* *)
(***********************************************************************)
-(* $Id: topstart.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
let _ = Topmain.main()
(* *)
(***********************************************************************)
-(* $Id: trace.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The "trace" facility *)
open Format
(* *)
(***********************************************************************)
-(* $Id: trace.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* The "trace" facility *)
open Format
(* *)
(***********************************************************************)
-(* $Id: annot.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Data types for annotations (Stypes.ml) *)
type call = Tail | Stack | Inline;;
(* *)
(***********************************************************************)
-(* $Id: btype.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Basic operations on core types *)
open Types
let l = String.length s in
if l < 4 then false else String.sub s (l-4) 4 = "#row"
+let is_constr_row t =
+ match t.desc with
+ Tconstr (Path.Pident id, _, _) -> is_row_name (Ident.name id)
+ | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
+ | _ -> false
+
(**********************************)
(* Utilities for type traversal *)
(* *)
(***********************************************************************)
-(* $Id: btype.mli 12726 2012-07-18 03:34:36Z garrigue $ *)
-
(* Basic operations on core types *)
open Asttypes
(**** Utilities for private abbreviations with fixed rows ****)
val has_constr_row: type_expr -> bool
val is_row_name: string -> bool
+val is_constr_row: type_expr -> bool
(**** Utilities for type traversal ****)
type error =
Not_a_typedtree of string
-
-
-
-
-
-
-
let need_to_clear_env =
try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
with Not_found -> true
-(* Re-introduce sharing after clearing environments *)
-let env_hcons = Hashtbl.create 133
-let keep_only_summary env =
- let new_env = Env.keep_only_summary env in
- try
- Hashtbl.find env_hcons new_env
- with Not_found ->
- Hashtbl.add env_hcons new_env new_env;
- new_env
-let clear_env_hcons () = Hashtbl.clear env_hcons
-
-
-
-
-module TypedtreeMap : sig
-
- open Asttypes
- open Typedtree
-
- module type MapArgument = sig
- val enter_structure : structure -> structure
- val enter_value_description : value_description -> value_description
- val enter_type_declaration : type_declaration -> type_declaration
- val enter_exception_declaration :
- exception_declaration -> exception_declaration
- val enter_pattern : pattern -> pattern
- val enter_expression : expression -> expression
- val enter_package_type : package_type -> package_type
- val enter_signature : signature -> signature
- val enter_signature_item : signature_item -> signature_item
- val enter_modtype_declaration : modtype_declaration -> modtype_declaration
- val enter_module_type : module_type -> module_type
- val enter_module_expr : module_expr -> module_expr
- val enter_with_constraint : with_constraint -> with_constraint
- val enter_class_expr : class_expr -> class_expr
- val enter_class_signature : class_signature -> class_signature
- val enter_class_description : class_description -> class_description
- val enter_class_type_declaration :
- class_type_declaration -> class_type_declaration
- val enter_class_infos : 'a class_infos -> 'a class_infos
- val enter_class_type : class_type -> class_type
- val enter_class_type_field : class_type_field -> class_type_field
- val enter_core_type : core_type -> core_type
- val enter_core_field_type : core_field_type -> core_field_type
- val enter_class_structure : class_structure -> class_structure
- val enter_class_field : class_field -> class_field
- val enter_structure_item : structure_item -> structure_item
-
- val leave_structure : structure -> structure
- val leave_value_description : value_description -> value_description
- val leave_type_declaration : type_declaration -> type_declaration
- val leave_exception_declaration :
- exception_declaration -> exception_declaration
- val leave_pattern : pattern -> pattern
- val leave_expression : expression -> expression
- val leave_package_type : package_type -> package_type
- val leave_signature : signature -> signature
- val leave_signature_item : signature_item -> signature_item
- val leave_modtype_declaration : modtype_declaration -> modtype_declaration
- val leave_module_type : module_type -> module_type
- val leave_module_expr : module_expr -> module_expr
- val leave_with_constraint : with_constraint -> with_constraint
- val leave_class_expr : class_expr -> class_expr
- val leave_class_signature : class_signature -> class_signature
- val leave_class_description : class_description -> class_description
- val leave_class_type_declaration :
- class_type_declaration -> class_type_declaration
- val leave_class_infos : 'a class_infos -> 'a class_infos
- val leave_class_type : class_type -> class_type
- val leave_class_type_field : class_type_field -> class_type_field
- val leave_core_type : core_type -> core_type
- val leave_core_field_type : core_field_type -> core_field_type
- val leave_class_structure : class_structure -> class_structure
- val leave_class_field : class_field -> class_field
- val leave_structure_item : structure_item -> structure_item
-
- end
-
- module MakeMap :
- functor
- (Iter : MapArgument) ->
- sig
- val map_structure : structure -> structure
- val map_pattern : pattern -> pattern
- val map_structure_item : structure_item -> structure_item
- val map_expression : expression -> expression
- val map_class_expr : class_expr -> class_expr
-
- val map_signature : signature -> signature
- val map_signature_item : signature_item -> signature_item
- val map_module_type : module_type -> module_type
- end
-
- module DefaultMapArgument : MapArgument
-
-end = struct
-
- open Asttypes
- open Typedtree
-
- module type MapArgument = sig
- val enter_structure : structure -> structure
- val enter_value_description : value_description -> value_description
- val enter_type_declaration : type_declaration -> type_declaration
- val enter_exception_declaration :
- exception_declaration -> exception_declaration
- val enter_pattern : pattern -> pattern
- val enter_expression : expression -> expression
- val enter_package_type : package_type -> package_type
- val enter_signature : signature -> signature
- val enter_signature_item : signature_item -> signature_item
- val enter_modtype_declaration : modtype_declaration -> modtype_declaration
- val enter_module_type : module_type -> module_type
- val enter_module_expr : module_expr -> module_expr
- val enter_with_constraint : with_constraint -> with_constraint
- val enter_class_expr : class_expr -> class_expr
- val enter_class_signature : class_signature -> class_signature
- val enter_class_description : class_description -> class_description
- val enter_class_type_declaration :
- class_type_declaration -> class_type_declaration
- val enter_class_infos : 'a class_infos -> 'a class_infos
- val enter_class_type : class_type -> class_type
- val enter_class_type_field : class_type_field -> class_type_field
- val enter_core_type : core_type -> core_type
- val enter_core_field_type : core_field_type -> core_field_type
- val enter_class_structure : class_structure -> class_structure
- val enter_class_field : class_field -> class_field
- val enter_structure_item : structure_item -> structure_item
-
- val leave_structure : structure -> structure
- val leave_value_description : value_description -> value_description
- val leave_type_declaration : type_declaration -> type_declaration
- val leave_exception_declaration :
- exception_declaration -> exception_declaration
- val leave_pattern : pattern -> pattern
- val leave_expression : expression -> expression
- val leave_package_type : package_type -> package_type
- val leave_signature : signature -> signature
- val leave_signature_item : signature_item -> signature_item
- val leave_modtype_declaration : modtype_declaration -> modtype_declaration
- val leave_module_type : module_type -> module_type
- val leave_module_expr : module_expr -> module_expr
- val leave_with_constraint : with_constraint -> with_constraint
- val leave_class_expr : class_expr -> class_expr
- val leave_class_signature : class_signature -> class_signature
- val leave_class_description : class_description -> class_description
- val leave_class_type_declaration :
- class_type_declaration -> class_type_declaration
- val leave_class_infos : 'a class_infos -> 'a class_infos
- val leave_class_type : class_type -> class_type
- val leave_class_type_field : class_type_field -> class_type_field
- val leave_core_type : core_type -> core_type
- val leave_core_field_type : core_field_type -> core_field_type
- val leave_class_structure : class_structure -> class_structure
- val leave_class_field : class_field -> class_field
- val leave_structure_item : structure_item -> structure_item
-
- end
-
-
- module MakeMap(Map : MapArgument) = struct
-
- let may_map f v =
- match v with
- None -> v
- | Some x -> Some (f x)
-
-
- open Misc
- open Asttypes
-
- let rec map_structure str =
- let str = Map.enter_structure str in
- let str_items = List.map map_structure_item str.str_items in
- Map.leave_structure { str with str_items = str_items }
-
- and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
-
- and map_bindings rec_flag list =
- List.map map_binding list
-
- and map_structure_item item =
- let item = Map.enter_structure_item item in
- let str_desc =
- match item.str_desc with
- Tstr_eval exp -> Tstr_eval (map_expression exp)
- | Tstr_value (rec_flag, list) ->
- Tstr_value (rec_flag, map_bindings rec_flag list)
- | Tstr_primitive (id, name, v) ->
- Tstr_primitive (id, name, map_value_description v)
- | Tstr_type list ->
- Tstr_type (List.map (
- fun (id, name, decl) ->
- (id, name, map_type_declaration decl) ) list)
- | Tstr_exception (id, name, decl) ->
- Tstr_exception (id, name, map_exception_declaration decl)
- | Tstr_exn_rebind (id, name, path, lid) ->
- Tstr_exn_rebind (id, name, path, lid)
- | Tstr_module (id, name, mexpr) ->
- Tstr_module (id, name, map_module_expr mexpr)
- | Tstr_recmodule list ->
- let list =
- List.map (fun (id, name, mtype, mexpr) ->
- (id, name, map_module_type mtype, map_module_expr mexpr)
- ) list
- in
- Tstr_recmodule list
- | Tstr_modtype (id, name, mtype) ->
- Tstr_modtype (id, name, map_module_type mtype)
- | Tstr_open (path, lid) -> Tstr_open (path, lid)
- | Tstr_class list ->
- let list =
- List.map (fun (ci, string_list, virtual_flag) ->
- let ci = Map.enter_class_infos ci in
- let ci_expr = map_class_expr ci.ci_expr in
- (Map.leave_class_infos { ci with ci_expr = ci_expr},
- string_list, virtual_flag)
- ) list
- in
- Tstr_class list
- | Tstr_class_type list ->
- let list = List.map (fun (id, name, ct) ->
- let ct = Map.enter_class_infos ct in
- let ci_expr = map_class_type ct.ci_expr in
- (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
- ) list in
- Tstr_class_type list
- | Tstr_include (mexpr, idents) ->
- Tstr_include (map_module_expr mexpr, idents)
- in
- Map.leave_structure_item { item with str_desc = str_desc}
-
- and map_value_description v =
- let v = Map.enter_value_description v in
- let val_desc = map_core_type v.val_desc in
- Map.leave_value_description { v with val_desc = val_desc }
-
- and map_type_declaration decl =
- let decl = Map.enter_type_declaration decl in
- let typ_cstrs = List.map (fun (ct1, ct2, loc) ->
- (map_core_type ct1,
- map_core_type ct2,
- loc)
- ) decl.typ_cstrs in
- let typ_kind = match decl.typ_kind with
- Ttype_abstract -> Ttype_abstract
- | Ttype_variant list ->
- let list = List.map (fun (s, name, cts, loc) ->
- (s, name, List.map map_core_type cts, loc)
- ) list in
- Ttype_variant list
- | Ttype_record list ->
- let list =
- List.map (fun (s, name, mut, ct, loc) ->
- (s, name, mut, map_core_type ct, loc)
- ) list in
- Ttype_record list
- in
- let typ_manifest =
- match decl.typ_manifest with
- None -> None
- | Some ct -> Some (map_core_type ct)
- in
- Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs;
- typ_kind = typ_kind; typ_manifest = typ_manifest }
-
- and map_exception_declaration decl =
- let decl = Map.enter_exception_declaration decl in
- let exn_params = List.map map_core_type decl.exn_params in
- let decl = { exn_params = exn_params;
- exn_exn = decl.exn_exn;
- exn_loc = decl.exn_loc } in
- Map.leave_exception_declaration decl;
-
- and map_pattern pat =
- let pat = Map.enter_pattern pat in
- let pat_desc =
- match pat.pat_desc with
- | Tpat_alias (pat1, p, text) ->
- let pat1 = map_pattern pat1 in
- Tpat_alias (pat1, p, text)
- | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
- | Tpat_construct (path, lid, cstr_decl, args, arity) ->
- Tpat_construct (path, lid, cstr_decl,
- List.map map_pattern args, arity)
- | Tpat_variant (label, pato, rowo) ->
- let pato = match pato with
- None -> pato
- | Some pat -> Some (map_pattern pat)
- in
- Tpat_variant (label, pato, rowo)
- | Tpat_record (list, closed) ->
- Tpat_record (List.map (fun (path, lid, lab_desc, pat) ->
- (path, lid, lab_desc, map_pattern pat) ) list, closed)
- | Tpat_array list -> Tpat_array (List.map map_pattern list)
- | Tpat_or (p1, p2, rowo) ->
- Tpat_or (map_pattern p1, map_pattern p2, rowo)
- | Tpat_lazy p -> Tpat_lazy (map_pattern p)
- | Tpat_constant _
- | Tpat_any
- | Tpat_var _ -> pat.pat_desc
-
- in
- let pat_extra = List.map map_pat_extra pat.pat_extra in
- Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra }
-
- and map_pat_extra pat_extra =
- match pat_extra with
- | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc)
- | (Tpat_type _ | Tpat_unpack), _ -> pat_extra
-
- and map_expression exp =
- let exp = Map.enter_expression exp in
- let exp_desc =
- match exp.exp_desc with
- Texp_ident (_, _, _)
- | Texp_constant _ -> exp.exp_desc
- | Texp_let (rec_flag, list, exp) ->
- Texp_let (rec_flag,
- map_bindings rec_flag list,
- map_expression exp)
- | Texp_function (label, cases, partial) ->
- Texp_function (label, map_bindings Nonrecursive cases, partial)
- | Texp_apply (exp, list) ->
- Texp_apply (map_expression exp,
- List.map (fun (label, expo, optional) ->
- let expo =
- match expo with
- None -> expo
- | Some exp -> Some (map_expression exp)
- in
- (label, expo, optional)
- ) list )
- | Texp_match (exp, list, partial) ->
- Texp_match (
- map_expression exp,
- map_bindings Nonrecursive list,
- partial
- )
- | Texp_try (exp, list) ->
- Texp_try (
- map_expression exp,
- map_bindings Nonrecursive list
- )
- | Texp_tuple list ->
- Texp_tuple (List.map map_expression list)
- | Texp_construct (path, lid, cstr_desc, args, arity) ->
- Texp_construct (path, lid, cstr_desc,
- List.map map_expression args, arity )
- | Texp_variant (label, expo) ->
- let expo =match expo with
- None -> expo
- | Some exp -> Some (map_expression exp)
- in
- Texp_variant (label, expo)
- | Texp_record (list, expo) ->
- let list =
- List.map (fun (path, lid, lab_desc, exp) ->
- (path, lid, lab_desc, map_expression exp)
- ) list in
- let expo = match expo with
- None -> expo
- | Some exp -> Some (map_expression exp)
- in
- Texp_record (list, expo)
- | Texp_field (exp, path, lid, label) ->
- Texp_field (map_expression exp, path, lid, label)
- | Texp_setfield (exp1, path, lid, label, exp2) ->
- Texp_setfield (
- map_expression exp1,
- path, lid,
- label,
- map_expression exp2)
- | Texp_array list ->
- Texp_array (List.map map_expression list)
- | Texp_ifthenelse (exp1, exp2, expo) ->
- Texp_ifthenelse (
- map_expression exp1,
- map_expression exp2,
- match expo with
- None -> expo
- | Some exp -> Some (map_expression exp)
- )
- | Texp_sequence (exp1, exp2) ->
- Texp_sequence (
- map_expression exp1,
- map_expression exp2
- )
- | Texp_while (exp1, exp2) ->
- Texp_while (
- map_expression exp1,
- map_expression exp2
- )
- | Texp_for (id, name, exp1, exp2, dir, exp3) ->
- Texp_for (
- id, name,
- map_expression exp1,
- map_expression exp2,
- dir,
- map_expression exp3
- )
- | Texp_when (exp1, exp2) ->
- Texp_when (
- map_expression exp1,
- map_expression exp2
- )
- | Texp_send (exp, meth, expo) ->
- Texp_send (map_expression exp, meth, may_map map_expression expo)
- | Texp_new (path, lid, cl_decl) -> exp.exp_desc
- | Texp_instvar (_, path, _) -> exp.exp_desc
- | Texp_setinstvar (path, lid, path2, exp) ->
- Texp_setinstvar (path, lid, path2, map_expression exp)
- | Texp_override (path, list) ->
- Texp_override (
- path,
- List.map (fun (path, lid, exp) ->
- (path, lid, map_expression exp)
- ) list
- )
- | Texp_letmodule (id, name, mexpr, exp) ->
- Texp_letmodule (
- id, name,
- map_module_expr mexpr,
- map_expression exp
- )
- | Texp_assert exp -> Texp_assert (map_expression exp)
- | Texp_assertfalse -> exp.exp_desc
- | Texp_lazy exp -> Texp_lazy (map_expression exp)
- | Texp_object (cl, string_list) ->
- Texp_object (map_class_structure cl, string_list)
- | Texp_pack (mexpr) ->
- Texp_pack (map_module_expr mexpr)
- in
- let exp_extra = List.map map_exp_extra exp.exp_extra in
- Map.leave_expression {
- exp with
- exp_desc = exp_desc;
- exp_extra = exp_extra }
-
- and map_exp_extra exp_extra =
- let loc = snd exp_extra in
- match fst exp_extra with
- | Texp_constraint (Some ct, None) ->
- Texp_constraint (Some (map_core_type ct), None), loc
- | Texp_constraint (None, Some ct) ->
- Texp_constraint (None, Some (map_core_type ct)), loc
- | Texp_constraint (Some ct1, Some ct2) ->
- Texp_constraint (Some (map_core_type ct1),
- Some (map_core_type ct2)), loc
- | Texp_poly (Some ct) ->
- Texp_poly (Some ( map_core_type ct )), loc
- | Texp_newtype _
- | Texp_constraint (None, None)
- | Texp_open _
- | Texp_poly None -> exp_extra
-
-
- and map_package_type pack =
- let pack = Map.enter_package_type pack in
- let pack_fields = List.map (
- fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in
- Map.leave_package_type { pack with pack_fields = pack_fields }
-
- and map_signature sg =
- let sg = Map.enter_signature sg in
- let sig_items = List.map map_signature_item sg.sig_items in
- Map.leave_signature { sg with sig_items = sig_items }
-
- and map_signature_item item =
- let item = Map.enter_signature_item item in
- let sig_desc =
- match item.sig_desc with
- Tsig_value (id, name, v) ->
- Tsig_value (id, name, map_value_description v)
- | Tsig_type list -> Tsig_type (
- List.map (fun (id, name, decl) ->
- (id, name, map_type_declaration decl)
- ) list
- )
- | Tsig_exception (id, name, decl) ->
- Tsig_exception (id, name, map_exception_declaration decl)
- | Tsig_module (id, name, mtype) ->
- Tsig_module (id, name, map_module_type mtype)
- | Tsig_recmodule list ->
- Tsig_recmodule (List.map (
- fun (id, name, mtype) ->
- (id, name, map_module_type mtype) ) list)
- | Tsig_modtype (id, name, mdecl) ->
- Tsig_modtype (id, name, map_modtype_declaration mdecl)
- | Tsig_open (path, lid) -> item.sig_desc
- | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid)
- | Tsig_class list -> Tsig_class (List.map map_class_description list)
- | Tsig_class_type list ->
- Tsig_class_type (List.map map_class_type_declaration list)
- in
- Map.leave_signature_item { item with sig_desc = sig_desc }
-
- and map_modtype_declaration mdecl =
- let mdecl = Map.enter_modtype_declaration mdecl in
- let mdecl =
- match mdecl with
- Tmodtype_abstract -> Tmodtype_abstract
- | Tmodtype_manifest mtype ->
- Tmodtype_manifest (map_module_type mtype)
- in
- Map.leave_modtype_declaration mdecl
-
-
- and map_class_description cd =
- let cd = Map.enter_class_description cd in
- let ci_expr = map_class_type cd.ci_expr in
- Map.leave_class_description { cd with ci_expr = ci_expr}
-
- and map_class_type_declaration cd =
- let cd = Map.enter_class_type_declaration cd in
- let ci_expr = map_class_type cd.ci_expr in
- Map.leave_class_type_declaration { cd with ci_expr = ci_expr }
-
- and map_module_type mty =
- let mty = Map.enter_module_type mty in
- let mty_desc =
- match mty.mty_desc with
- Tmty_ident (path, lid) -> mty.mty_desc
- | Tmty_signature sg -> Tmty_signature (map_signature sg)
- | Tmty_functor (id, name, mtype1, mtype2) ->
- Tmty_functor (id, name, map_module_type mtype1,
- map_module_type mtype2)
- | Tmty_with (mtype, list) ->
- Tmty_with (map_module_type mtype,
- List.map (fun (path, lid, withc) ->
- (path, lid, map_with_constraint withc)
- ) list)
- | Tmty_typeof mexpr ->
- Tmty_typeof (map_module_expr mexpr)
- in
- Map.leave_module_type { mty with mty_desc = mty_desc}
-
- and map_with_constraint cstr =
- let cstr = Map.enter_with_constraint cstr in
- let cstr =
- match cstr with
- Twith_type decl -> Twith_type (map_type_declaration decl)
- | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
- | Twith_module (path, lid) -> cstr
- | Twith_modsubst (path, lid) -> cstr
- in
- Map.leave_with_constraint cstr
-
- and map_module_expr mexpr =
- let mexpr = Map.enter_module_expr mexpr in
- let mod_desc =
- match mexpr.mod_desc with
- Tmod_ident (p, lid) -> mexpr.mod_desc
- | Tmod_structure st -> Tmod_structure (map_structure st)
- | Tmod_functor (id, name, mtype, mexpr) ->
- Tmod_functor (id, name, map_module_type mtype,
- map_module_expr mexpr)
- | Tmod_apply (mexp1, mexp2, coercion) ->
- Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)
- | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) ->
- Tmod_constraint (map_module_expr mexpr, mod_type,
- Tmodtype_implicit, coercion)
- | Tmod_constraint (mexpr, mod_type,
- Tmodtype_explicit mtype, coercion) ->
- Tmod_constraint (map_module_expr mexpr, mod_type,
- Tmodtype_explicit (map_module_type mtype),
- coercion)
- | Tmod_unpack (exp, mod_type) ->
- Tmod_unpack (map_expression exp, mod_type)
- in
- Map.leave_module_expr { mexpr with mod_desc = mod_desc }
-
- and map_class_expr cexpr =
- let cexpr = Map.enter_class_expr cexpr in
- let cl_desc =
- match cexpr.cl_desc with
- | Tcl_constraint (cl, None, string_list1, string_list2, concr ) ->
- Tcl_constraint (map_class_expr cl, None, string_list1,
- string_list2, concr)
- | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr)
- | Tcl_fun (label, pat, priv, cl, partial) ->
- Tcl_fun (label, map_pattern pat,
- List.map (fun (id, name, exp) ->
- (id, name, map_expression exp)) priv,
- map_class_expr cl, partial)
-
- | Tcl_apply (cl, args) ->
- Tcl_apply (map_class_expr cl,
- List.map (fun (label, expo, optional) ->
- (label, may_map map_expression expo,
- optional)
- ) args)
- | Tcl_let (rec_flat, bindings, ivars, cl) ->
- Tcl_let (rec_flat, map_bindings rec_flat bindings,
- List.map (fun (id, name, exp) ->
- (id, name, map_expression exp)) ivars,
- map_class_expr cl)
-
- | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
- Tcl_constraint ( map_class_expr cl,
- Some (map_class_type clty), vals, meths, concrs)
-
- | Tcl_ident (id, name, tyl) ->
- Tcl_ident (id, name, List.map map_core_type tyl)
- in
- Map.leave_class_expr { cexpr with cl_desc = cl_desc }
-
- and map_class_type ct =
- let ct = Map.enter_class_type ct in
- let cltyp_desc =
- match ct.cltyp_desc with
- Tcty_signature csg -> Tcty_signature (map_class_signature csg)
- | Tcty_constr (path, lid, list) ->
- Tcty_constr (path, lid, List.map map_core_type list)
- | Tcty_fun (label, ct, cl) ->
- Tcty_fun (label, map_core_type ct, map_class_type cl)
- in
- Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
-
- and map_class_signature cs =
- let cs = Map.enter_class_signature cs in
- let csig_self = map_core_type cs.csig_self in
- let csig_fields = List.map map_class_type_field cs.csig_fields in
- Map.leave_class_signature { cs with
- csig_self = csig_self; csig_fields = csig_fields }
-
-
- and map_class_type_field ctf =
- let ctf = Map.enter_class_type_field ctf in
- let ctf_desc =
- match ctf.ctf_desc with
- Tctf_inher ct -> Tctf_inher (map_class_type ct)
- | Tctf_val (s, mut, virt, ct) ->
- Tctf_val (s, mut, virt, map_core_type ct)
- | Tctf_virt (s, priv, ct) ->
- Tctf_virt (s, priv, map_core_type ct)
- | Tctf_meth (s, priv, ct) ->
- Tctf_meth (s, priv, map_core_type ct)
- | Tctf_cstr (ct1, ct2) ->
- Tctf_cstr (map_core_type ct1, map_core_type ct2)
- in
- Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
-
- and map_core_type ct =
- let ct = Map.enter_core_type ct in
- let ctyp_desc =
- match ct.ctyp_desc with
- Ttyp_any
- | Ttyp_var _ -> ct.ctyp_desc
- | Ttyp_arrow (label, ct1, ct2) ->
- Ttyp_arrow (label, map_core_type ct1, map_core_type ct2)
- | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list)
- | Ttyp_constr (path, lid, list) ->
- Ttyp_constr (path, lid, List.map map_core_type list)
- | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list)
- | Ttyp_class (path, lid, list, labels) ->
- Ttyp_class (path, lid, List.map map_core_type list, labels)
- | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
- | Ttyp_variant (list, bool, labels) ->
- Ttyp_variant (List.map map_row_field list, bool, labels)
- | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct)
- | Ttyp_package pack -> Ttyp_package (map_package_type pack)
- in
- Map.leave_core_type { ct with ctyp_desc = ctyp_desc }
-
- and map_core_field_type cft =
- let cft = Map.enter_core_field_type cft in
- let field_desc = match cft.field_desc with
- Tcfield_var -> Tcfield_var
- | Tcfield (s, ct) -> Tcfield (s, map_core_type ct)
- in
- Map.leave_core_field_type { cft with field_desc = field_desc }
-
- and map_class_structure cs =
- let cs = Map.enter_class_structure cs in
- let cstr_pat = map_pattern cs.cstr_pat in
- let cstr_fields = List.map map_class_field cs.cstr_fields in
- Map.leave_class_structure { cs with cstr_pat = cstr_pat;
- cstr_fields = cstr_fields }
-
- and map_row_field rf =
- match rf with
- Ttag (label, bool, list) ->
- Ttag (label, bool, List.map map_core_type list)
- | Tinherit ct -> Tinherit (map_core_type ct)
-
- and map_class_field cf =
- let cf = Map.enter_class_field cf in
- let cf_desc =
- match cf.cf_desc with
- Tcf_inher (ovf, cl, super, vals, meths) ->
- Tcf_inher (ovf, map_class_expr cl, super, vals, meths)
- | Tcf_constr (cty, cty') ->
- Tcf_constr (map_core_type cty, map_core_type cty')
- | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) ->
- Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty),
- override)
- | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) ->
- Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp),
- override)
- | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
- Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty),
- override)
- | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
- Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp),
- override)
- | Tcf_init exp -> Tcf_init (map_expression exp)
- in
- Map.leave_class_field { cf with cf_desc = cf_desc }
-
- end
-
-module DefaultMapArgument = struct
-
- let enter_structure t = t
- let enter_value_description t = t
- let enter_type_declaration t = t
- let enter_exception_declaration t = t
- let enter_pattern t = t
- let enter_expression t = t
- let enter_package_type t = t
- let enter_signature t = t
- let enter_signature_item t = t
- let enter_modtype_declaration t = t
- let enter_module_type t = t
- let enter_module_expr t = t
- let enter_with_constraint t = t
- let enter_class_expr t = t
- let enter_class_signature t = t
- let enter_class_description t = t
- let enter_class_type_declaration t = t
- let enter_class_infos t = t
- let enter_class_type t = t
- let enter_class_type_field t = t
- let enter_core_type t = t
- let enter_core_field_type t = t
- let enter_class_structure t = t
- let enter_class_field t = t
- let enter_structure_item t = t
-
-
- let leave_structure t = t
- let leave_value_description t = t
- let leave_type_declaration t = t
- let leave_exception_declaration t = t
- let leave_pattern t = t
- let leave_expression t = t
- let leave_package_type t = t
- let leave_signature t = t
- let leave_signature_item t = t
- let leave_modtype_declaration t = t
- let leave_module_type t = t
- let leave_module_expr t = t
- let leave_with_constraint t = t
- let leave_class_expr t = t
- let leave_class_signature t = t
- let leave_class_description t = t
- let leave_class_type_declaration t = t
- let leave_class_infos t = t
- let leave_class_type t = t
- let leave_class_type_field t = t
- let leave_core_type t = t
- let leave_core_field_type t = t
- let leave_class_structure t = t
- let leave_class_field t = t
- let leave_structure_item t = t
-
- end
-
-end
+let keep_only_summary = Env.keep_only_summary
module ClearEnv = TypedtreeMap.MakeMap (struct
open TypedtreeMap
let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env }
let leave_expression e =
let exp_extra = List.map (function
- (Texp_open (path, lloc, env), loc) ->
- (Texp_open (path, lloc, keep_only_summary env), loc)
+ (Texp_open (ovf, path, lloc, env), loc) ->
+ (Texp_open (ovf, path, lloc, keep_only_summary env), loc)
| exp_extra -> exp_extra) e.exp_extra in
{ e with
exp_env = keep_only_summary e.exp_env;
end)
-let rec clear_part p = match p with
+let clear_part p = match p with
| Partial_structure s -> Partial_structure (ClearEnv.map_structure s)
| Partial_structure_item s ->
Partial_structure_item (ClearEnv.map_structure_item s)
let set_saved_types l = saved_types := l
let save_cmt filename modname binary_annots sourcefile initial_env sg =
- if !Clflags.binary_annotations
- && not !Clflags.print_types
- && not !Clflags.dont_write_files
- then begin
+ if !Clflags.binary_annotations && not !Clflags.print_types then begin
let imports = Env.imported_units () in
let oc = open_out_bin filename in
let this_crc =
cmt_interface_digest = this_crc;
cmt_use_summaries = need_to_clear_env;
} in
- clear_env_hcons ();
output_cmt oc cmt;
close_out oc;
set_saved_types [];
(* *)
(***********************************************************************)
-(* $Id: ctype.ml 12726 2012-07-18 03:34:36Z garrigue $ *)
-
(* Operations on core types *)
open Misc
| Path.Pdot _ | Path.Papply _ -> false
let in_pervasives p =
- try ignore (Env.find_type p Env.initial); true
- with Not_found -> false
+ in_current_module p &&
+ try ignore (Env.find_type p Env.initial); true
+ with Not_found -> false
let is_datatype decl=
match decl.type_kind with
unmark_type ty;
tl
-let rec closed_type ty =
+let closed_type ty =
match free_vars ty with
[] -> ()
| (v, real) :: _ -> raise (Non_closed (v, real))
let rec update_level env level ty =
let ty = repr ty in
if ty.level > level then begin
- if Env.has_local_constraints env then begin
- match Env.gadt_instance_level env ty with
- Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
- | None -> ()
+ begin match Env.gadt_instance_level env ty with
+ Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
+ | None -> ()
end;
match ty.desc with
Tconstr(p, tl, abbrev) when level < get_level env p ->
set_level ty level;
iter_type_expr (update_level env level) ty
| Tfield(lab, _, ty1, _)
- when lab = dummy_method && (repr ty1).level > level->
- raise (Unify [(ty, newvar2 level)])
+ when lab = dummy_method && (repr ty1).level > level ->
+ raise (Unify [(ty1, newvar2 level)])
| _ ->
set_level ty level;
(* XXX what about abbreviations in Tconstr ? *)
Tconstr (path, tyl, abbrev) ->
let variance =
try (Env.find_type path env).type_variance
- with Not_found -> List.map (fun _ -> (true,true,true)) tyl in
+ with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
abbrev := Mnil;
List.iter2
- (fun (co,cn,ct) t ->
- if ct then generalize_contravariant env var_level t
+ (fun v t ->
+ if Variance.(mem May_weak v)
+ then generalize_contravariant env var_level t
else generalize_expansive env var_level t)
variance tyl
| Tpackage (_, _, tyl) ->
if keep then more else newty more.desc
| _ -> assert false
in
+ let row =
+ match repr more' with (* PR#6163 *)
+ {desc=Tconstr _} when not row.row_fixed ->
+ {row with row_fixed = true}
+ | _ -> row
+ in
+ (* Open row if partial for pattern and contains Reither *)
+ let more', row =
+ match partial with
+ Some (free_univars, false) when row.row_closed
+ && not row.row_fixed && TypeSet.is_empty (free_univars ty) ->
+ let not_reither (_, f) =
+ match row_field_repr f with
+ Reither _ -> false
+ | _ -> true
+ in
+ if List.for_all not_reither row.row_fields
+ then (more', row) else
+ (newty2 (if keep then more.level else !current_level)
+ (Tvar None),
+ {row_fields = List.filter not_reither row.row_fields;
+ row_more = more; row_bound = ();
+ row_closed = false; row_fixed = false; row_name = None})
+ | _ -> (more', row)
+ in
(* Register new type first for recursion *)
more.desc <- Tsubst(newgenty(Ttuple[more';t]));
(* Return a new copy *)
}
let instance_constructor ?in_pattern cstr =
- let ty_res = copy cstr.cstr_res in
- let ty_args = List.map copy cstr.cstr_args in
begin match in_pattern with
| None -> ()
| Some (env, newtype_lev) ->
Env.enter_type (get_new_abstract_name name) decl !env in
env := new_env;
let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
- link_type (copy existential) to_unify
+ let tv = copy existential in
+ assert (is_Tvar tv);
+ link_type tv to_unify
in
List.iter process cstr.cstr_existentials
end;
+ let ty_res = copy cstr.cstr_res in
+ let ty_args = List.map copy cstr.cstr_args in
cleanup_types ();
(ty_args, ty_res)
let unify' = (* Forward declaration *)
ref (fun env ty1 ty2 -> raise (Unify []))
-let rec subst env level priv abbrev ty params args body =
+let subst env level priv abbrev ty params args body =
if List.length params <> List.length args then raise (Unify []);
let old_level = !current_level in
current_level := level;
| _ -> ()
end;
(* For gadts, remember type as non exportable *)
+ (* The ambiguous level registered for ty' should be the highest *)
if !trace_gadt_instances then begin
- match lv with
- Some lv ->
+ match max lv (Env.gadt_instance_level env ty) with
+ None -> ()
+ | Some lv ->
if level < lv then raise (Unify [(ty, newvar2 level)]);
Env.add_gadt_instances env lv [ty; ty']
- | None ->
- match Env.gadt_instance_level env ty with
- Some lv -> Env.add_gadt_instances env lv [ty']
- | None -> ()
end;
ty'
end
let expand_abbrev ty =
expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+ try expand_abbrev env (repr ty) with Cannot_expand -> assert false
+
+(* Check whether a type can be expanded *)
let safe_abbrev env ty =
let snap = Btype.snapshot () in
try ignore (expand_abbrev env ty); true
Btype.backtrack snap;
false
+(* Expand the head of a type once.
+ Raise Cannot_expand if the type cannot be expanded.
+ May raise Unify, if a recursion was hidden in the type. *)
let try_expand_once env ty =
let ty = repr ty in
match ty.desc with
Tconstr (p, _, _) -> repr (expand_abbrev env ty)
| _ -> raise Cannot_expand
-let _ = forward_try_expand_once := try_expand_once
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+ let snap = Btype.snapshot () in
+ try try_expand_once env ty
+ with Unify _ ->
+ Btype.backtrack snap; raise Cannot_expand
-(* Fully expand the head of a type.
- Raise Cannot_expand if the type cannot be expanded.
- May raise Unify, if a recursion was hidden in the type. *)
-let rec try_expand_head env ty =
- let ty' = try_expand_once env ty in
- let ty'' =
- try try_expand_head env ty'
- with Cannot_expand -> ty'
- in
- if Env.has_local_constraints env then begin
- match Env.gadt_instance_level env ty'' with
- None -> ()
- | Some lv -> Env.add_gadt_instance_chain env lv ty
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+ let ty' = try_once env ty in
+ try try_expand_head try_once env ty'
+ with Cannot_expand -> ty'
+
+let try_expand_head try_once env ty =
+ let ty' = try_expand_head try_once env ty in
+ begin match Env.gadt_instance_level env ty' with
+ None -> ()
+ | Some lv -> Env.add_gadt_instance_chain env lv ty
end;
- ty''
+ ty'
-(* Expand once the head of a type *)
-let expand_head_once env ty =
- try expand_abbrev env (repr ty) with Cannot_expand -> assert false
-
-(* Fully expand the head of a type. *)
+(* Unsafe full expansion, may raise Unify. *)
let expand_head_unif env ty =
- try try_expand_head env ty with Cannot_expand -> repr ty
+ try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
+(* Safe version of expand_head, never fails *)
let expand_head env ty =
- let snap = Btype.snapshot () in
- try try_expand_head env ty
- with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
- Btype.backtrack snap;
- repr ty
+ try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_once := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration *)
+
+let rec extract_concrete_typedecl env ty =
+ let ty = repr ty in
+ match ty.desc with
+ Tconstr (p, _, _) ->
+ let decl = Env.find_type p env in
+ if decl.type_kind <> Type_abstract then (p, p, decl) else
+ let ty =
+ try try_expand_once env ty with Cannot_expand -> raise Not_found
+ in
+ let (_, p', decl) = extract_concrete_typedecl env ty in
+ (p, p', decl)
+ | _ -> raise Not_found
(* Implementing function [expand_head_opt], the compiler's own version of
[expand_head] used for type-based optimisations.
(* Recursively expand the head of a type.
Also expand #-types. *)
-let rec full_expand env ty =
+let full_expand env ty =
let ty = repr (expand_head env ty) in
match ty.desc with
Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
Not_found ->
false
+let generic_private_abbrev env path =
+ try
+ match Env.find_type path env with
+ {type_kind = Type_abstract;
+ type_private = Private;
+ type_manifest = Some body} ->
+ (repr body).level = generic_level
+ | _ -> false
+ with Not_found -> false
(*****************)
(* Occur check *)
non_recursive_abbrev env ty0 (try_expand_once_opt env ty)
with Cannot_expand ->
if !Clflags.recursive_types &&
- (in_current_module p || in_pervasives p ||
+ (in_pervasives p ||
try is_datatype (Env.find_type p env) with Not_found -> false)
then ()
else iter_type_expr (non_recursive_abbrev env ty0) ty
if List.memq ty visited || !Clflags.recursive_types then raise Occur;
iter_type_expr (occur_rec env (ty::visited) ty0) ty
with Occur -> try
- let ty' = try_expand_head env ty in
+ let ty' = try_expand_head try_expand_once env ty in
(* Maybe we could simply make a recursive call here,
but it seems it could make the occur check loop
(see change in rev. 1.58) *)
begin try
let td = Env.find_type p env in
List.iter2
- (fun t (pos,neg,_) -> if pos || neg then occur_rec bound t)
+ (fun t v ->
+ if Variance.(mem May_pos v || mem May_neg v)
+ then occur_rec bound t)
tl td.type_variance
with Not_found ->
List.iter (occur_rec bound) tl
let get_univar_family univar_pairs univars =
if univars = [] then TypeSet.empty else
- let rec insert s = function
+ let insert s = function
cl1, (_::_ as cl2) ->
if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
add_univars s cl2
| Tconstr (p, tl, _) ->
begin try
let td = Env.find_type p env in
- List.iter2 (fun t (pos,neg,_) -> if pos || neg then occur t)
+ List.iter2
+ (fun t v ->
+ if Variance.(mem May_pos v || mem May_neg v) then occur t)
tl td.type_variance
with Not_found ->
List.iter occur tl
let t = create_fresh_constr ty.level name in
link_type ty t
| Tvariant r ->
- if not (static_row r) then iterator (row_more r);
+ let r = row_repr r in
+ if not (static_row r) then begin
+ if r.row_fixed then iterator (row_more r) else
+ let m = r.row_more in
+ match m.desc with
+ Tvar o ->
+ let name = match o with Some s -> s | _ -> "ex" in
+ let t = create_fresh_constr m.level name in
+ let row =
+ {r with row_fields=[]; row_fixed=true; row_more = t} in
+ link_type m (newty2 m.level (Tvariant row))
+ | _ -> assert false
+ end;
iter_row iterator r
| Tconstr (p, _, _) when is_object_type p ->
iter_type_expr iterator (full_expand !env ty)
in
iterator t
-let is_abstract_newtype env p =
+let is_newtype env p =
try
let decl = Env.find_type p env in
- not (decl.type_newtype_level = None) &&
- decl.type_manifest = None &&
- decl.type_kind = Type_abstract
+ decl.type_newtype_level <> None &&
+ decl.type_kind = Type_abstract &&
+ decl.type_private = Public
with Not_found -> false
+let non_aliasable p decl =
+ (* in_pervasives p || (subsumed by in_current_module) *)
+ in_current_module p && decl.type_newtype_level = None
+
(* mcomp type_pairs subst env t1 t2 does not raise an
exception if it is possible that t1 and t2 are actually
equal, assuming the types in type_pairs are equal and
and that both their objects and variants are closed
*)
-let rec mcomp type_pairs subst env t1 t2 =
+let rec mcomp type_pairs env t1 t2 =
if t1 == t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
if t1 == t2 then () else
- match (t1.desc, t2.desc) with
- | (Tvar _, _)
- | (_, Tvar _) ->
- fatal_error "types should not include variables"
- | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
- ()
- | _ ->
- let t1' = expand_head_opt env t1 in
- let t2' = expand_head_opt env t2 in
- (* Expansion may have changed the representative of the types... *)
- let t1' = repr t1' and t2' = repr t2' in
- if t1' == t2' then () else
- begin try TypePairs.find type_pairs (t1', t2')
- with Not_found ->
- TypePairs.add type_pairs (t1', t2') ();
- match (t1'.desc, t2'.desc) with
- (Tvar _, Tvar _) -> assert false
- | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
- when l1 = l2 || not (is_optional l1 || is_optional l2) ->
- mcomp type_pairs subst env t1 t2;
- mcomp type_pairs subst env u1 u2;
- | (Ttuple tl1, Ttuple tl2) ->
- mcomp_list type_pairs subst env tl1 tl2
- | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
- mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2
- | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
- when Path.same p1 p2 && n1 = n2 ->
- mcomp_list type_pairs subst env tl1 tl2
- | (Tvariant row1, Tvariant row2) ->
- mcomp_row type_pairs subst env row1 row2
- | (Tobject (fi1, _), Tobject (fi2, _)) ->
- mcomp_fields type_pairs subst env fi1 fi2
- | (Tfield _, Tfield _) -> (* Actually unused *)
- mcomp_fields type_pairs subst env t1' t2'
- | (Tnil, Tnil) ->
- ()
- | (Tpoly (t1, []), Tpoly (t2, [])) ->
- mcomp type_pairs subst env t1 t2
- | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- enter_poly env univar_pairs t1 tl1 t2 tl2
- (mcomp type_pairs subst env)
- | (Tunivar _, Tunivar _) ->
- unify_univar t1' t2' !univar_pairs
- | (_, _) ->
- raise (Unify [])
- end
+ match (t1.desc, t2.desc) with
+ | (Tvar _, _)
+ | (_, Tvar _) ->
+ ()
+ | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+ ()
+ | _ ->
+ let t1' = expand_head_opt env t1 in
+ let t2' = expand_head_opt env t2 in
+ (* Expansion may have changed the representative of the types... *)
+ let t1' = repr t1' and t2' = repr t2' in
+ if t1' == t2' then () else
+ begin try TypePairs.find type_pairs (t1', t2')
+ with Not_found ->
+ TypePairs.add type_pairs (t1', t2') ();
+ match (t1'.desc, t2'.desc) with
+ (Tvar _, Tvar _) -> assert false
+ | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+ when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+ mcomp type_pairs env t1 t2;
+ mcomp type_pairs env u1 u2;
+ | (Ttuple tl1, Ttuple tl2) ->
+ mcomp_list type_pairs env tl1 tl2
+ | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+ mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+ | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+ let decl = Env.find_type p env in
+ if non_aliasable p decl then raise (Unify [])
+ | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+ when Path.same p1 p2 && n1 = n2 ->
+ mcomp_list type_pairs env tl1 tl2
+ | (Tvariant row1, Tvariant row2) ->
+ mcomp_row type_pairs env row1 row2
+ | (Tobject (fi1, _), Tobject (fi2, _)) ->
+ mcomp_fields type_pairs env fi1 fi2
+ | (Tfield _, Tfield _) -> (* Actually unused *)
+ mcomp_fields type_pairs env t1' t2'
+ | (Tnil, Tnil) ->
+ ()
+ | (Tpoly (t1, []), Tpoly (t2, [])) ->
+ mcomp type_pairs env t1 t2
+ | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+ enter_poly env univar_pairs t1 tl1 t2 tl2
+ (mcomp type_pairs env)
+ | (Tunivar _, Tunivar _) ->
+ unify_univar t1' t2' !univar_pairs
+ | (_, _) ->
+ raise (Unify [])
+ end
-and mcomp_list type_pairs subst env tl1 tl2 =
+and mcomp_list type_pairs env tl1 tl2 =
if List.length tl1 <> List.length tl2 then
raise (Unify []);
- List.iter2 (mcomp type_pairs subst env) tl1 tl2
+ List.iter2 (mcomp type_pairs env) tl1 tl2
-and mcomp_fields type_pairs subst env ty1 ty2 =
+and mcomp_fields type_pairs env ty1 ty2 =
if not (concrete_object ty1 && concrete_object ty2) then assert false;
let (fields2, rest2) = flatten_fields ty2 in
let (fields1, rest1) = flatten_fields ty1 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
- mcomp type_pairs subst env rest1 rest2;
+ mcomp type_pairs env rest1 rest2;
if miss1 <> [] && (object_row ty1).desc = Tnil
|| miss2 <> [] && (object_row ty2).desc = Tnil then raise (Unify []);
List.iter
(function (n, k1, t1, k2, t2) ->
mcomp_kind k1 k2;
- mcomp type_pairs subst env t1 t2)
+ mcomp type_pairs env t1 t2)
pairs
and mcomp_kind k1 k2 =
| (Fpresent, Fpresent) -> ()
| _ -> raise (Unify [])
-and mcomp_row type_pairs subst env row1 row2 =
+and mcomp_row type_pairs env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
let cannot_erase (_,f) =
| (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
raise (Unify [])
| Rpresent(Some t1), Rpresent(Some t2) ->
- mcomp type_pairs subst env t1 t2
+ mcomp type_pairs env t1 t2
| Rpresent(Some t1), Reither(false, tl2, _, _) ->
- List.iter (mcomp type_pairs subst env t1) tl2
+ List.iter (mcomp type_pairs env t1) tl2
| Reither(false, tl1, _, _), Rpresent(Some t2) ->
- List.iter (mcomp type_pairs subst env t2) tl1
+ List.iter (mcomp type_pairs env t2) tl1
| _ -> ())
pairs
-and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 =
- let non_aliased p decl =
- in_pervasives p ||
- in_current_module p && decl.type_newtype_level = None
- in
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
try
let decl = Env.find_type p1 env in
let decl' = Env.find_type p2 env in
- if Path.same p1 p2 then
- (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2)
+ if Path.same p1 p2 then begin
+ (* Format.eprintf "@[%a@ %a@]@."
+ !print_raw (newconstr p1 tl2) !print_raw (newconstr p2 tl2);
+ if non_aliasable p1 decl then Format.eprintf "non_aliasable@."
+ else Format.eprintf "aliasable@."; *)
+ let inj =
+ try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+ with Not_found -> List.map (fun _ -> false) tl1
+ in
+ List.iter2
+ (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+ inj (List.combine tl1 tl2)
+ end
else match decl.type_kind, decl'.type_kind with
| Type_record (lst,r), Type_record (lst',r') when r = r' ->
- mcomp_list type_pairs subst env tl1 tl2;
- mcomp_record_description type_pairs subst env lst lst'
+ mcomp_list type_pairs env tl1 tl2;
+ mcomp_record_description type_pairs env lst lst'
| Type_variant v1, Type_variant v2 ->
- mcomp_list type_pairs subst env tl1 tl2;
- mcomp_variant_description type_pairs subst env v1 v2
+ mcomp_list type_pairs env tl1 tl2;
+ mcomp_variant_description type_pairs env v1 v2
| Type_variant _, Type_record _
| Type_record _, Type_variant _ -> raise (Unify [])
| _ ->
- if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl')
- || is_datatype decl && non_aliased p2 decl' then raise (Unify [])
+ if non_aliasable p1 decl && (non_aliasable p2 decl'||is_datatype decl')
+ || is_datatype decl && non_aliasable p2 decl' then raise (Unify [])
with Not_found -> ()
-and mcomp_type_option type_pairs subst env t t' =
+and mcomp_type_option type_pairs env t t' =
match t, t' with
None, None -> ()
- | Some t, Some t' -> mcomp type_pairs subst env t t'
+ | Some t, Some t' -> mcomp type_pairs env t t'
| _ -> raise (Unify [])
-and mcomp_variant_description type_pairs subst env =
+and mcomp_variant_description type_pairs env xs ys =
let rec iter = fun x y ->
match x, y with
- (name,mflag,t) :: xs, (name', mflag', t') :: ys ->
- mcomp_type_option type_pairs subst env t t';
- if name = name' && mflag = mflag'
+ (id, tl, t) :: xs, (id', tl', t') :: ys ->
+ mcomp_type_option type_pairs env t t';
+ mcomp_list type_pairs env tl tl';
+ if Ident.name id = Ident.name id'
then iter xs ys
else raise (Unify [])
| [],[] -> ()
| _ -> raise (Unify [])
in
- iter
+ iter xs ys
-and mcomp_record_description type_pairs subst env =
+and mcomp_record_description type_pairs env =
let rec iter = fun x y ->
match x, y with
- (name, mutable_flag, t) :: xs, (name', mutable_flag', t') :: ys ->
- mcomp type_pairs subst env t t';
- if name = name' && mutable_flag = mutable_flag'
+ (id, mutable_flag, t) :: xs, (id', mutable_flag', t') :: ys ->
+ mcomp type_pairs env t t';
+ if Ident.name id = Ident.name id' && mutable_flag = mutable_flag'
then iter xs ys
else raise (Unify [])
| [], [] -> ()
iter
let mcomp env t1 t2 =
- mcomp (TypePairs.create 4) () env t1 t2
+ mcomp (TypePairs.create 4) env t1 t2
(* Real unification *)
let rec unify (env:Env.t ref) t1 t2 =
(* First step: special cases (optimizations) *)
- if unify_eq !env t1 t2 then () else
+ if t1 == t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
if unify_eq !env t1 t2 then () else
|| has_cached_expansion p2 !a2) ->
update_level !env t1.level t2;
link_type t1 t2
+ | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+ when Env.has_local_constraints !env
+ && is_newtype !env p1 && is_newtype !env p2 ->
+ (* Do not use local constraints more than necessary *)
+ begin try
+ if find_newtype_level !env p1 < find_newtype_level !env p2 then
+ unify env t1 (try_expand_once !env t2)
+ else
+ unify env (try_expand_once !env t1) t2
+ with Cannot_expand ->
+ unify2 env t1 t2
+ end
| _ ->
unify2 env t1 t2
end;
let t1 = repr t1 and t2 = repr t2 in
if !trace_gadt_instances then begin
- match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with
- Some lv1, Some lv2 ->
- if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
- if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1
- | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2
- | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1
- | None, None -> ()
+ (* All types in chains already have the same ambiguity levels *)
+ let ilevel t =
+ match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in
+ let lv1 = ilevel t1 and lv2 = ilevel t2 in
+ if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
+ if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1
end;
let t1, t2 =
if !Clflags.principal
unify_univar t1' t2' !univar_pairs;
link_type t1' t2'
| (Tvar _, _) ->
- occur !env t1 t2';
+ occur !env t1' t2;
occur_univar !env t2;
link_type t1' t2;
| (_, Tvar _) ->
- occur !env t2 t1';
+ occur !env t2' t1;
occur_univar !env t1;
link_type t2' t1;
| (Tfield _, Tfield _) -> (* special case for GADTs *)
unify_list env tl1 tl2
| (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
if !umode = Expression || not !generate_equations
- || in_current_module p1 || in_pervasives p1
+ || in_current_module p1 (* || in_pervasives p1 *)
|| try is_datatype (Env.find_type p1 !env) with Not_found -> false
then
unify_list env tl1 tl2
else
- set_mode Pattern ~generate:false (fun () -> unify_list env tl1 tl2)
+ let inj =
+ try List.map Variance.(mem Inj)
+ (Env.find_type p1 !env).type_variance
+ with Not_found -> List.map (fun _ -> false) tl1
+ in
+ List.iter2
+ (fun i (t1, t2) ->
+ if i then unify env t1 t2 else
+ set_mode Pattern ~generate:false
+ begin fun () ->
+ let snap = snapshot () in
+ try unify env t1 t2 with Unify _ ->
+ backtrack snap;
+ reify env t1; reify env t2
+ end)
+ inj (List.combine tl1 tl2)
| (Tconstr ((Path.Pident p) as path,[],_),
Tconstr ((Path.Pident p') as path',[],_))
- when is_abstract_newtype !env path && is_abstract_newtype !env path'
+ when is_newtype !env path && is_newtype !env path'
&& !generate_equations ->
let source,destination =
if find_newtype_level !env path > find_newtype_level !env path'
else p',t1'
in add_gadt_equation env source destination
| (Tconstr ((Path.Pident p) as path,[],_), _)
- when is_abstract_newtype !env path && !generate_equations ->
+ when is_newtype !env path && !generate_equations ->
reify env t2';
local_non_recursive_abbrev !env (Path.Pident p) t2';
add_gadt_equation env p t2'
| (_, Tconstr ((Path.Pident p) as path,[],_))
- when is_abstract_newtype !env path && !generate_equations ->
+ when is_newtype !env path && !generate_equations ->
reify env t1' ;
local_non_recursive_abbrev !env (Path.Pident p) t1';
add_gadt_equation env p t1'
- | (Tconstr (_,[],_), _) | (_, Tconstr (_,[],_)) when !umode = Pattern ->
+ | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
reify env t1';
reify env t2';
- mcomp !env t1' t2'
+ if !generate_equations then mcomp !env t1' t2'
| (Tobject (fi1, nm1), Tobject (fi2, _)) ->
unify_fields env fi1 fi2;
(* Type [t2'] may have been instantiated by [unify_fields] *)
| _ -> ()
end
| (Tvariant row1, Tvariant row2) ->
- unify_row env row1 row2
+ if !umode = Expression then
+ unify_row env row1 row2
+ else begin
+ let snap = snapshot () in
+ try unify_row env row1 row2
+ with Unify _ ->
+ backtrack snap;
+ reify env t1';
+ reify env t2';
+ if !generate_equations then mcomp !env t1' t2'
+ end
| (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
begin match field_kind_repr kind with
Fvar r when f <> dummy_method ->
(2) the original label is not optional
*)
-let rec filter_arrow env t l =
+let filter_arrow env t l =
let t = expand_head_trace env t in
match t.desc with
Tvar _ ->
raise (Unify [])
(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
-let rec filter_method env name priv ty =
+let filter_method env name priv ty =
let ty = expand_head_trace env ty in
match ty.desc with
Tvar _ ->
| (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
()
| _ ->
- let t1' = expand_head_unif env t1 in
- let t2' = expand_head_unif env t2 in
+ let t1' = expand_head env t1 in
+ let t2' = expand_head env t2 in
(* Expansion may have changed the representative of the types... *)
let t1' = repr t1' and t2' = repr t2' in
if t1' == t2' then () else
raise (Unify [])
| _ when static_row row1 -> ()
| _ when may_inst ->
- if not (static_row row2) then moregen_occur env rm1.level rm2;
- let ext =
- if r2 = [] then rm2 else
- let row_ext = {row2 with row_fields = r2} in
- iter_row (moregen_occur env rm1.level) row_ext;
- newty2 rm1.level (Tvariant row_ext)
- in
+ let ext = newgenty (Tvariant {row2 with row_fields = r2}) in
+ moregen_occur env rm1.level ext;
link_type rm1 ext
| Tconstr _, Tconstr _ ->
moregen inst_nongen type_pairs env rm1 rm2
let expand_head_rigid env ty =
let old = !rigid_variants in
rigid_variants := true;
- let ty' = expand_head_unif env ty in
+ let ty' = expand_head env ty in
rigid_variants := old; ty'
let normalize_subst subst =
type class_match_failure =
CM_Virtual_class
| CM_Parameter_arity_mismatch of int * int
- | CM_Type_parameter_mismatch of (type_expr * type_expr) list
- | CM_Class_type_mismatch of class_type * class_type
- | CM_Parameter_mismatch of (type_expr * type_expr) list
- | CM_Val_type_mismatch of string * (type_expr * type_expr) list
- | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+ | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
+ | CM_Class_type_mismatch of Env.t * class_type * class_type
+ | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
+ | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
+ | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
| CM_Non_mutable_value of string
| CM_Non_concrete_value of string
| CM_Missing_value of string
moregen_clty true type_pairs env cty1 cty2
| Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
- raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
+ raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
end;
moregen_clty false type_pairs env cty1' cty2'
| Cty_signature sign1, Cty_signature sign2 ->
(fun (lab, k1, t1, k2, t2) ->
begin try moregen true type_pairs env t1 t2 with Unify trace ->
raise (Failure [CM_Meth_type_mismatch
- (lab, expand_trace env trace)])
+ (lab, env, expand_trace env trace)])
end)
pairs;
Vars.iter
let (mut', v', ty') = Vars.find lab sign1.cty_vars in
try moregen true type_pairs env ty' ty with Unify trace ->
raise (Failure [CM_Val_type_mismatch
- (lab, expand_trace env trace)]))
+ (lab, env, expand_trace env trace)]))
sign2.cty_vars
| _ ->
raise (Failure [])
with
Failure error when trace || error = [] ->
- raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
+ raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
let match_class_types ?(trace=true) env pat_sch subj_sch =
let type_pairs = TypePairs.create 53 in
Failure r -> r
end
| error ->
- CM_Class_type_mismatch (patt, subj)::error
+ CM_Class_type_mismatch (env, patt, subj)::error
in
current_level := old_level;
res
equal_clty true type_pairs subst env cty1 cty2
| Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
- raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
+ raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
end;
equal_clty false type_pairs subst env cty1' cty2'
| Cty_signature sign1, Cty_signature sign2 ->
begin try eqtype true type_pairs subst env t1 t2 with
Unify trace ->
raise (Failure [CM_Meth_type_mismatch
- (lab, expand_trace env trace)])
+ (lab, env, expand_trace env trace)])
end)
pairs;
Vars.iter
let (_, _, ty') = Vars.find lab sign1.cty_vars in
try eqtype true type_pairs subst env ty' ty with Unify trace ->
raise (Failure [CM_Val_type_mismatch
- (lab, expand_trace env trace)]))
+ (lab, env, expand_trace env trace)]))
sign2.cty_vars
| _ ->
raise
(Failure (if trace then []
- else [CM_Class_type_mismatch (cty1, cty2)]))
+ else [CM_Class_type_mismatch (env, cty1, cty2)]))
with
Failure error when trace ->
- raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
+ raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
let match_class_declarations env patt_params patt_type subj_params subj_type =
let type_pairs = TypePairs.create 53 in
List.iter2 (fun p s ->
try eqtype true type_pairs subst env p s with Unify trace ->
raise (Failure [CM_Type_parameter_mismatch
- (expand_trace env trace)]))
+ (env, expand_trace env trace)]))
patt_params subj_params;
(* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
equal_clty false type_pairs subst env
then warn := true;
let tl' =
List.map2
- (fun (co,cn,_) t ->
+ (fun v t ->
+ let (co,cn) = Variance.get_upper v in
if cn then
if co then (t, Unchanged)
else build_subtype env visited loops (not posi) level t
let subtype_error env trace =
raise (Subtype (expand_trace env (List.rev trace), []))
-let private_abbrev env path =
- try
- let decl = Env.find_type path env in
- decl.type_private = Private && decl.type_manifest <> None
- with Not_found -> false
-
(* check list inclusion, assuming lists are ordered *)
let rec included nl1 nl2 =
match nl1, nl2 with
begin try
let decl = Env.find_type p1 env in
List.fold_left2
- (fun cstrs (co, cn, _) (t1, t2) ->
+ (fun cstrs v (t1, t2) ->
+ let (co, cn) = Variance.get_upper v in
if co then
if cn then
(trace, newty2 t1.level (Ttuple[t1]),
with Not_found ->
(trace, t1, t2, !univar_pairs)::cstrs
end
- | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
+ | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+ subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
| (Tobject (f1, _), Tobject (f2, _))
when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
(* Same row variable implies same object. *)
(* *)
(***********************************************************************)
-(* $Id: ctype.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Operations on core types *)
open Asttypes
(** The compiler's own version of [expand_head] necessary for type-based
optimisations. *)
val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+ Env.t -> type_expr -> Path.t * Path.t * type_declaration
+ (* Return the original path of the types, and the first concrete
+ type declaration found expanding it.
+ Raise [Not_found] if none appears or not a type constructor. *)
val enforce_constraints: Env.t -> type_expr -> unit
type class_match_failure =
CM_Virtual_class
| CM_Parameter_arity_mismatch of int * int
- | CM_Type_parameter_mismatch of (type_expr * type_expr) list
- | CM_Class_type_mismatch of class_type * class_type
- | CM_Parameter_mismatch of (type_expr * type_expr) list
- | CM_Val_type_mismatch of string * (type_expr * type_expr) list
- | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+ | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
+ | CM_Class_type_mismatch of Env.t * class_type * class_type
+ | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
+ | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
+ | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
| CM_Non_mutable_value of string
| CM_Non_concrete_value of string
| CM_Missing_value of string
(* *)
(***********************************************************************)
-(* $Id: datarepr.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Compute constructor and label descriptions from type declarations,
determining their representation. *)
-open Misc
open Asttypes
open Types
open Btype
(* Simplified version of Ctype.free_vars *)
-let rec free_vars ty =
+let free_vars ty =
let ret = ref TypeSet.empty in
let rec loop ty =
let ty = repr ty in
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
- | (name, ty_args, ty_res_opt) :: rem ->
+ | (id, ty_args, ty_res_opt) :: rem ->
let ty_res =
match ty_res_opt with
| Some ty_res' -> ty_res'
TypeSet.elements (TypeSet.diff arg_vars res_vars)
in
let cstr =
- { cstr_res = ty_res;
+ { cstr_name = Ident.name id;
+ cstr_res = ty_res;
cstr_existentials = existentials;
cstr_args = ty_args;
cstr_arity = List.length ty_args;
cstr_private = priv;
cstr_generalized = ty_res_opt <> None
} in
- (name, cstr) :: descr_rem in
+ (id, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let exception_descr path_exc decl =
- { cstr_res = Predef.type_exn;
+ { cstr_name = Path.last path_exc;
+ cstr_res = Predef.type_exn;
cstr_existentials = [];
cstr_args = decl.exn_args;
cstr_arity = List.length decl.exn_args;
let all_labels = Array.create (List.length lbls) dummy_label in
let rec describe_labels num = function
[] -> []
- | (name, mut_flag, ty_arg) :: rest ->
+ | (id, mut_flag, ty_arg) :: rest ->
let lbl =
- { lbl_name = Ident.name name;
+ { lbl_name = Ident.name id;
lbl_res = ty_res;
lbl_arg = ty_arg;
lbl_mut = mut_flag;
lbl_repres = repres;
lbl_private = priv } in
all_labels.(num) <- lbl;
- (name, lbl) :: describe_labels (num+1) rest in
+ (id, lbl) :: describe_labels (num+1) rest in
describe_labels 0 lbls
exception Constr_not_found
(* *)
(***********************************************************************)
-(* $Id: datarepr.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Compute constructor and label descriptions from type declarations,
determining their representation. *)
(* *)
(***********************************************************************)
-(* $Id: env.ml 12820 2012-08-03 20:23:26Z frisch $ *)
-
(* Environment handling *)
open Cmi_format
(string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t
= Hashtbl.create 16
+let prefixed_sg = Hashtbl.create 113
+
type error =
- | Illegal_renaming of string * string
+ | Illegal_renaming of string * string * string
| Inconsistent_import of string * string * string
| Need_recursive_types of string * string
val force : ('a -> 'b) -> ('a,'b) t -> 'b
val create : 'a -> ('a,'b) t
+ val is_val : ('a,'b) t -> bool
end = struct
x := Raise e;
raise e
+ let is_val x =
+ match !x with Done _ -> true | _ -> false
+
let create x =
let x = ref (Thunk x) in
x
module EnvTbl =
struct
(* A table indexed by identifier, with an extra slot to record usage. *)
- type 'a t = ('a * bool ref) Ident.tbl
+ type 'a t = ('a * (unit -> unit)) Ident.tbl
let empty = Ident.empty
- let current_slot = ref (ref true)
+ let nothing = fun () -> ()
+
+ let already_defined s tbl =
+ try ignore (Ident.find_name s tbl); true
+ with Not_found -> false
+
+ let add kind slot id x tbl ref_tbl =
+ let slot =
+ match slot with
+ | None -> nothing
+ | Some f ->
+ (fun () ->
+ let s = Ident.name id in
+ f kind s (already_defined s ref_tbl)
+ )
+ in
+ Ident.add id (x, slot) tbl
- let add id x tbl =
- Ident.add id (x, !current_slot) tbl
+ let add_dont_track id x tbl =
+ Ident.add id (x, nothing) tbl
let find_same_not_using id tbl =
fst (Ident.find_same id tbl)
let find_same id tbl =
let (x, slot) = Ident.find_same id tbl in
- slot := true;
+ slot ();
x
let find_name s tbl =
let (x, slot) = Ident.find_name s tbl in
- slot := true;
+ slot ();
x
- let with_slot slot f x =
- let old_slot = !current_slot in
- current_slot := slot;
- try_finally
- (fun () -> f x)
- (fun () -> current_slot := old_slot)
+ let find_all s tbl =
+ Ident.find_all s tbl
- let keys tbl =
- Ident.keys tbl
+ let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
+ let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
end
+type type_descriptions =
+ constructor_description list * label_description list
+
type t = {
values: (Path.t * value_description) EnvTbl.t;
- annotations: (Path.t * Annot.ident) EnvTbl.t;
- constrs: (Path.t * constructor_description) EnvTbl.t;
- labels: (Path.t * label_description) EnvTbl.t;
- constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
- types: (Path.t * type_declaration) EnvTbl.t;
+ constrs: constructor_description EnvTbl.t;
+ labels: label_description EnvTbl.t;
+ types: (Path.t * (type_declaration * type_descriptions)) EnvTbl.t;
modules: (Path.t * module_type) EnvTbl.t;
modtypes: (Path.t * modtype_declaration) EnvTbl.t;
components: (Path.t * module_components) EnvTbl.t;
and structure_components = {
mutable comp_values: (string, (value_description * int)) Tbl.t;
- mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
- mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
- mutable comp_labels: (string, (label_description * int)) Tbl.t;
- mutable comp_constrs_by_path:
- (string, (constructor_description list * int)) Tbl.t;
- mutable comp_types: (string, (type_declaration * int)) Tbl.t;
+ mutable comp_constrs: (string, (constructor_description * int) list) Tbl.t;
+ mutable comp_labels: (string, (label_description * int) list) Tbl.t;
+ mutable comp_types:
+ (string, ((type_declaration * type_descriptions) * int)) Tbl.t;
mutable comp_modules:
(string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t;
mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
let subst_modtype_maker (subst, mty) = Subst.modtype subst mty
let empty = {
- values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty;
+ values = EnvTbl.empty; constrs = EnvTbl.empty;
labels = EnvTbl.empty; types = EnvTbl.empty;
- constrs_by_path = EnvTbl.empty;
modules = EnvTbl.empty; modtypes = EnvTbl.empty;
components = EnvTbl.empty; classes = EnvTbl.empty;
cltypes = EnvTbl.empty;
let is_local (p, _) = is_ident p
+let is_local_exn = function
+ | {cstr_tag = Cstr_exception (p, _)} -> is_ident p
+ | _ -> false
+
let diff env1 env2 =
diff_keys is_local env1.values env2.values @
- diff_keys is_local env1.constrs env2.constrs @
+ diff_keys is_local_exn env1.constrs env2.constrs @
diff_keys is_local env1.modules env2.modules @
diff_keys is_local env1.classes env2.classes
(* Reading persistent structures from .cmi files *)
-let read_pers_struct modname filename =
+let read_pers_struct modname filename = (
let cmi = read_cmi filename in
let name = cmi.cmi_name in
let sign = cmi.cmi_sign in
ps_filename = filename;
ps_flags = flags } in
if ps.ps_name <> modname then
- raise(Error(Illegal_renaming(ps.ps_name, filename)));
+ raise(Error(Illegal_renaming(modname, ps.ps_name, filename)));
check_consistency filename ps.ps_crcs;
List.iter
(function Rectypes ->
ps.ps_flags;
Hashtbl.add persistent_structures modname (Some ps);
ps
+)
let find_pers_struct name =
if name = "*predef*" then raise Not_found;
Hashtbl.clear persistent_structures;
Consistbl.clear crc_units;
Hashtbl.clear value_declarations;
- Hashtbl.clear type_declarations
-
-let reset_missing_cmis () =
- let l = Hashtbl.fold
+ Hashtbl.clear type_declarations;
+ Hashtbl.clear used_constructors;
+ Hashtbl.clear prefixed_sg
+
+let reset_cache_toplevel () =
+ (* Delete 'missing cmi' entries from the cache. *)
+ let l =
+ Hashtbl.fold
(fun name r acc -> if r = None then name :: acc else acc)
- persistent_structures [] in
- List.iter (Hashtbl.remove persistent_structures) l
+ persistent_structures []
+ in
+ List.iter (Hashtbl.remove persistent_structures) l;
+ Hashtbl.clear value_declarations;
+ Hashtbl.clear type_declarations;
+ Hashtbl.clear used_constructors;
+ Hashtbl.clear prefixed_sg
+
let set_unit_name name =
current_unit := name
let find_value =
find (fun env -> env.values) (fun sc -> sc.comp_values)
-and find_annot =
- find (fun env -> env.annotations) (fun sc -> sc.comp_annotations)
-and find_type =
+and find_type_full =
find (fun env -> env.types) (fun sc -> sc.comp_types)
-and find_constructors =
- find (fun env -> env.constrs_by_path) (fun sc -> sc.comp_constrs_by_path)
and find_modtype =
find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
and find_class =
and find_cltype =
find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+let find_type p env =
+ fst (find_type_full p env)
+let find_type_descrs p env =
+ snd (find_type_full p env)
+
(* Find the manifest type associated to a type when appropriate:
- the type should be public or should have a private row,
- the type should have an associated manifest type. *)
(* Lookup by name *)
+exception Recmodule
+
let rec lookup_module_descr lid env =
match lid with
Lident s ->
match lid with
Lident s ->
begin try
- EnvTbl.find_name s env.modules
+ let (_, ty) as r = EnvTbl.find_name s env.modules in
+ begin match ty with
+ | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
+ (* see #5965 *)
+ raise Recmodule
+ | _ -> ()
+ end;
+ r
with Not_found ->
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
| Lapply(l1, l2) ->
raise Not_found
+let lookup_all_simple proj1 proj2 shadow lid env =
+ match lid with
+ Lident s ->
+ let xl = EnvTbl.find_all s (proj1 env) in
+ let rec do_shadow =
+ function
+ | [] -> []
+ | ((x, f) :: xs) ->
+ (x, f) ::
+ (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
+ in
+ do_shadow xl
+ | Ldot(l, s) ->
+ let (p, desc) = lookup_module_descr l env in
+ begin match EnvLazy.force !components_of_module_maker' desc with
+ Structure_comps c ->
+ let comps =
+ try Tbl.find s (proj2 c) with Not_found -> []
+ in
+ List.map
+ (fun (data, pos) -> (data, (fun () -> ())))
+ comps
+ | Functor_comps f ->
+ raise Not_found
+ end
+ | Lapply(l1, l2) ->
+ raise Not_found
+
let has_local_constraints env = env.local_constraints
+let cstr_shadow cstr1 cstr2 =
+ match cstr1.cstr_tag, cstr2.cstr_tag with
+ Cstr_exception _, Cstr_exception _ -> true
+ | _ -> false
+
+let lbl_shadow lbl1 lbl2 = false
+
let lookup_value =
lookup (fun env -> env.values) (fun sc -> sc.comp_values)
-let lookup_annot id e =
- lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
-and lookup_constructor =
- lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
-and lookup_label =
- lookup (fun env -> env.labels) (fun sc -> sc.comp_labels)
+and lookup_all_constructors =
+ lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+ cstr_shadow
+and lookup_all_labels =
+ lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+ lbl_shadow
and lookup_type =
lookup (fun env -> env.types) (fun sc -> sc.comp_types)
and lookup_modtype =
Hashtbl.add value_declarations key callback
let set_type_used_callback name td callback =
+ let loc = td.type_loc in
+ if loc.Location.loc_ghost then ()
+ else let key = (name, loc) in
let old =
- try Hashtbl.find type_declarations (name, td.type_loc)
- with Not_found -> assert false in
- Hashtbl.replace type_declarations (name, td.type_loc) (fun () -> callback old)
+ try Hashtbl.find type_declarations key
+ with Not_found -> assert false
+ in
+ Hashtbl.replace type_declarations key (fun () -> callback old)
let lookup_value lid env =
let (_, desc) as r = lookup_value lid env in
r
let lookup_type lid env =
- let (_, desc) as r = lookup_type lid env in
- mark_type_used (Longident.last lid) desc;
- r
+ let (path, (decl, _)) = lookup_type lid env in
+ mark_type_used (Longident.last lid) decl;
+ (path, decl)
(* [path] must be the path to a type, not to a module ! *)
-let rec path_subst_last path id =
+let path_subst_last path id =
match path with
Pident _ -> Pident id
| Pdot (p, name, pos) -> Pdot(p, Ident.name id, pos)
| Papply (p1, p2) -> assert false
let mark_type_path env path =
- let decl = try find_type path env with Not_found -> assert false in
- mark_type_used (Path.last path) decl
+ try
+ let decl = find_type path env in
+ mark_type_used (Path.last path) decl
+ with Not_found -> ()
-let ty_path = function
+let ty_path t =
+ match repr t with
| {desc=Tconstr(path, _, _)} -> path
| _ -> assert false
let lookup_constructor lid env =
- let (_,desc) as c = lookup_constructor lid env in
- mark_type_path env (ty_path desc.cstr_res);
- c
+ match lookup_all_constructors lid env with
+ [] -> raise Not_found
+ | (desc, use) :: _ ->
+ mark_type_path env (ty_path desc.cstr_res);
+ use ();
+ desc
+
+let is_lident = function
+ Lident _ -> true
+ | _ -> false
+
+let lookup_all_constructors lid env =
+ try
+ let cstrs = lookup_all_constructors lid env in
+ let wrap_use desc use () =
+ mark_type_path env (ty_path desc.cstr_res);
+ use ()
+ in
+ List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
+ with
+ Not_found when is_lident lid -> []
let mark_constructor usage env name desc =
match desc.cstr_tag with
mark_constructor_used usage ty_name ty_decl name
let lookup_label lid env =
- let (_,desc) as c = lookup_label lid env in
- mark_type_path env (ty_path desc.lbl_res);
- c
+ match lookup_all_labels lid env with
+ [] -> raise Not_found
+ | (desc, use) :: _ ->
+ mark_type_path env (ty_path desc.lbl_res);
+ use ();
+ desc
+
+let lookup_all_labels lid env =
+ try
+ let lbls = lookup_all_labels lid env in
+ let wrap_use desc use () =
+ mark_type_path env (ty_path desc.lbl_res);
+ use ()
+ in
+ List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
+ with
+ Not_found when is_lident lid -> []
let lookup_class lid env =
let (_, desc) as r = lookup_class lid env in
mark_type_path env desc.clty_path;
r
+(* Iter on an environment (ignoring the body of functors and
+ not yet evaluated structures) *)
+
+let iter_env proj1 proj2 f env =
+ Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
+ let rec iter_components path path' mcomps =
+ (* if EnvLazy.is_val mcomps then *)
+ match EnvLazy.force !components_of_module_maker' mcomps with
+ Structure_comps comps ->
+ Tbl.iter
+ (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d))
+ (proj2 comps);
+ Tbl.iter
+ (fun s (c, n) ->
+ iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c)
+ comps.comp_components
+ | Functor_comps _ -> ()
+ in
+ Hashtbl.iter
+ (fun s pso ->
+ match pso with None -> ()
+ | Some ps ->
+ let id = Pident (Ident.create_persistent s) in
+ iter_components id id ps.ps_comps)
+ persistent_structures;
+ Ident.iter
+ (fun id ((path, comps), _) -> iter_components (Pident id) path comps)
+ env.components
+
+let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f
+
+let same_types env1 env2 =
+ env1.types == env2.types && env1.components == env2.components
+
+let used_persistent () =
+ let r = ref Concr.empty in
+ Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r)
+ persistent_structures;
+ !r
+
+let find_all_comps proj s (p,mcomps) =
+ match EnvLazy.force !components_of_module_maker' mcomps with
+ Functor_comps _ -> []
+ | Structure_comps comps ->
+ try let (c,n) = Tbl.find s (proj comps) in [Pdot(p,s,n), c]
+ with Not_found -> []
+
+let rec find_shadowed_comps path env =
+ match path with
+ Pident id ->
+ List.map fst (Ident.find_all (Ident.name id) env.components)
+ | Pdot (p, s, _) ->
+ let l = find_shadowed_comps p env in
+ let l' =
+ List.map (find_all_comps (fun comps -> comps.comp_components) s) l in
+ List.flatten l'
+ | Papply _ -> []
+
+let find_shadowed proj1 proj2 path env =
+ match path with
+ Pident id ->
+ List.map fst (Ident.find_all (Ident.name id) (proj1 env))
+ | Pdot (p, s, _) ->
+ let l = find_shadowed_comps p env in
+ let l' = List.map (find_all_comps proj2 s) l in
+ List.flatten l'
+ | Papply _ -> []
+
+let find_shadowed_types path env =
+ let l =
+ find_shadowed
+ (fun env -> env.types) (fun comps -> comps.comp_types) path env
+ in
+ List.map fst l
+
+
(* GADT instance tracking *)
let add_gadt_instance_level lv env =
let (pl, final_sub) = prefix_idents root pos sub rem in
(p::pl, final_sub)
+let subst_signature sub sg =
+ List.map
+ (fun item ->
+ match item with
+ | Sig_value(id, decl) ->
+ Sig_value (id, Subst.value_description sub decl)
+ | Sig_type(id, decl, x) ->
+ Sig_type(id, Subst.type_declaration sub decl, x)
+ | Sig_exception(id, decl) ->
+ Sig_exception (id, Subst.exception_declaration sub decl)
+ | Sig_module(id, mty, x) ->
+ Sig_module(id, Subst.modtype sub mty,x)
+ | Sig_modtype(id, decl) ->
+ Sig_modtype(id, Subst.modtype_declaration sub decl)
+ | Sig_class(id, decl, x) ->
+ Sig_class(id, Subst.class_declaration sub decl, x)
+ | Sig_class_type(id, decl, x) ->
+ Sig_class_type(id, Subst.cltype_declaration sub decl, x)
+ )
+ sg
+
+
+let prefix_idents_and_subst root sub sg =
+ let (pl, sub) = prefix_idents root 0 sub sg in
+ pl, sub, lazy (subst_signature sub sg)
+
+let prefix_idents_and_subst root sub sg =
+ if sub = Subst.identity then
+ let sgs =
+ try
+ Hashtbl.find prefixed_sg root
+ with Not_found ->
+ let sgs = ref [] in
+ Hashtbl.add prefixed_sg root sgs;
+ sgs
+ in
+ try
+ List.assq sg !sgs
+ with Not_found ->
+ let r = prefix_idents_and_subst root sub sg in
+ sgs := (sg, r) :: !sgs;
+ r
+ else
+ prefix_idents_and_subst root sub sg
+
(* Compute structure descriptions *)
+let add_to_tbl id decl tbl =
+ let decls =
+ try Tbl.find id tbl with Not_found -> [] in
+ Tbl.add id (decl :: decls) tbl
+
let rec components_of_module env sub path mty =
EnvLazy.create (env, sub, path, mty)
(match scrape_modtype mty env with
Mty_signature sg ->
let c =
- { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+ { comp_values = Tbl.empty;
comp_constrs = Tbl.empty;
comp_labels = Tbl.empty; comp_types = Tbl.empty;
- comp_constrs_by_path = Tbl.empty;
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
comp_components = Tbl.empty; comp_classes = Tbl.empty;
comp_cltypes = Tbl.empty } in
- let (pl, sub) = prefix_idents path 0 sub sg in
+ let pl, sub, _ = prefix_idents_and_subst path sub sg in
let env = ref env in
let pos = ref 0 in
List.iter2 (fun item path ->
let decl' = Subst.value_description sub decl in
c.comp_values <-
Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
- if !Clflags.annotations then begin
- c.comp_annotations <-
- Tbl.add (Ident.name id) (Annot.Iref_external, !pos)
- c.comp_annotations;
- end;
begin match decl.val_kind with
Val_prim _ -> () | _ -> incr pos
end
| Sig_type(id, decl, _) ->
let decl' = Subst.type_declaration sub decl in
+ let constructors = List.map snd (constructors_of_type path decl') in
+ let labels = List.map snd (labels_of_type path decl') in
c.comp_types <-
- Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
- let constructors = constructors_of_type path decl' in
- c.comp_constrs_by_path <-
Tbl.add (Ident.name id)
- (List.map snd constructors, nopos) c.comp_constrs_by_path;
+ ((decl', (constructors, labels)), nopos)
+ c.comp_types;
List.iter
- (fun (name, descr) ->
+ (fun descr ->
c.comp_constrs <-
- Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs)
+ add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs)
constructors;
- let labels = labels_of_type path decl' in
List.iter
- (fun (name, descr) ->
+ (fun descr ->
c.comp_labels <-
- Tbl.add (Ident.name name) (descr, nopos) c.comp_labels)
- (labels);
- env := store_type_infos id path decl !env
+ add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels)
+ labels;
+ env := store_type_infos None id path decl !env !env
| Sig_exception(id, decl) ->
let decl' = Subst.exception_declaration sub decl in
let cstr = Datarepr.exception_descr path decl' in
+ let s = Ident.name id in
c.comp_constrs <-
- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
+ add_to_tbl s (cstr, !pos) c.comp_constrs;
incr pos
| Sig_module(id, mty, _) ->
let mty' = EnvLazy.create (sub, mty) in
let comps = components_of_module !env sub path mty in
c.comp_components <-
Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
- env := store_module id path mty !env;
+ env := store_module None id path mty !env !env;
incr pos
| Sig_modtype(id, decl) ->
let decl' = Subst.modtype_declaration sub decl in
c.comp_modtypes <-
Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
- env := store_modtype id path decl !env
+ env := store_modtype None id path decl !env !env
| Sig_class(id, decl, _) ->
let decl' = Subst.class_declaration sub decl in
c.comp_classes <-
fcomp_cache = Hashtbl.create 17 }
| Mty_ident p ->
Structure_comps {
- comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+ comp_values = Tbl.empty;
comp_constrs = Tbl.empty;
comp_labels = Tbl.empty;
- comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty;
+ comp_types = Tbl.empty;
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
comp_components = Tbl.empty; comp_classes = Tbl.empty;
comp_cltypes = Tbl.empty })
(fun () -> if not !used then Location.prerr_warning loc (warn name))
end;
-and store_value ?check id path decl env =
+and store_value ?check slot id path decl env renv =
may (fun f -> check_usage decl.val_loc id f value_declarations) check;
{ env with
- values = EnvTbl.add id (path, decl) env.values;
+ values = EnvTbl.add "value" slot id (path, decl) env.values renv.values;
summary = Env_value(env.summary, id, decl) }
-and store_annot id path annot env =
- if !Clflags.annotations then
- { env with
- annotations = EnvTbl.add id (path, annot) env.annotations }
- else env
-
-and store_type id path info env =
+and store_type slot id path info env renv =
let loc = info.type_loc in
check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
type_declarations;
let constructors = constructors_of_type path info in
let labels = labels_of_type path info in
+ let descrs = (List.map snd constructors, List.map snd labels) in
if not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_constructor ("", false, false))
then begin
let ty = Ident.name id in
List.iter
- begin fun (c, _) ->
- let c = Ident.name c in
+ begin fun (_, {cstr_name = c; _}) ->
let k = (ty, loc, c) in
if not (Hashtbl.mem used_constructors k) then
let used = constructor_usages () in
{ env with
constrs =
List.fold_right
- (fun (name, descr) constrs ->
- EnvTbl.add name (path_subst_last path name, descr) constrs)
+ (fun (id, descr) constrs ->
+ EnvTbl.add "constructor" slot id descr constrs renv.constrs)
constructors
env.constrs;
-
- constrs_by_path =
- EnvTbl.add id
- (path,List.map snd constructors) env.constrs_by_path;
labels =
List.fold_right
- (fun (name, descr) labels ->
- EnvTbl.add name (path_subst_last path name, descr) labels)
+ (fun (id, descr) labels ->
+ EnvTbl.add "label" slot id descr labels renv.labels)
labels
env.labels;
- types = EnvTbl.add id (path, info) env.types;
+ types = EnvTbl.add "type" slot id (path, (info, descrs)) env.types
+ renv.types;
summary = Env_type(env.summary, id, info) }
-and store_type_infos id path info env =
+and store_type_infos slot id path info env renv =
(* Simplified version of store_type that doesn't compute and store
constructor and label infos, but simply record the arity and
manifest-ness of the type. Used in components_of_module to
keep track of type abbreviations (e.g. type t = float) in the
computation of label representations. *)
{ env with
- types = EnvTbl.add id (path, info) env.types;
+ types = EnvTbl.add "type" slot id (path, (info,([],[]))) env.types
+ renv.types;
summary = Env_type(env.summary, id, info) }
-and store_exception id path decl env =
+and store_exception slot id path decl env renv =
let loc = decl.exn_loc in
if not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_exception ("", false))
end;
end;
{ env with
- constrs = EnvTbl.add id (path_subst_last path id,
- Datarepr.exception_descr path decl) env.constrs;
+ constrs = EnvTbl.add "constructor" slot id
+ (Datarepr.exception_descr path decl) env.constrs
+ renv.constrs;
summary = Env_exception(env.summary, id, decl) }
-and store_module id path mty env =
+and store_module slot id path mty env renv =
{ env with
- modules = EnvTbl.add id (path, mty) env.modules;
+ modules = EnvTbl.add "module" slot id (path, mty) env.modules renv.modules;
components =
- EnvTbl.add id (path, components_of_module env Subst.identity path mty)
- env.components;
+ EnvTbl.add "module" slot id
+ (path, components_of_module env Subst.identity path mty)
+ env.components renv.components;
summary = Env_module(env.summary, id, mty) }
-and store_modtype id path info env =
+and store_modtype slot id path info env renv =
{ env with
- modtypes = EnvTbl.add id (path, info) env.modtypes;
+ modtypes = EnvTbl.add "module type" slot id (path, info) env.modtypes
+ renv.modtypes;
summary = Env_modtype(env.summary, id, info) }
-and store_class id path desc env =
+and store_class slot id path desc env renv =
{ env with
- classes = EnvTbl.add id (path, desc) env.classes;
+ classes = EnvTbl.add "class" slot id (path, desc) env.classes renv.classes;
summary = Env_class(env.summary, id, desc) }
-and store_cltype id path desc env =
+and store_cltype slot id path desc env renv =
{ env with
- cltypes = EnvTbl.add id (path, desc) env.cltypes;
+ cltypes = EnvTbl.add "class type" slot id (path, desc) env.cltypes
+ renv.cltypes;
summary = Env_cltype(env.summary, id, desc) }
(* Compute the components of a functor application in a path. *)
(* Insertion of bindings by identifier *)
let add_value ?check id desc env =
- store_value ?check id (Pident id) desc env
+ store_value None ?check id (Pident id) desc env env
-let add_annot id annot env =
- store_annot id (Pident id) annot env
-
-and add_type id info env =
- store_type id (Pident id) info env
+let add_type id info env =
+ store_type None id (Pident id) info env env
and add_exception id decl env =
- store_exception id (Pident id) decl env
+ store_exception None id (Pident id) decl env env
and add_module id mty env =
- store_module id (Pident id) mty env
+ store_module None id (Pident id) mty env env
and add_modtype id info env =
- store_modtype id (Pident id) info env
+ store_modtype None id (Pident id) info env env
and add_class id ty env =
- store_class id (Pident id) ty env
+ store_class None id (Pident id) ty env env
and add_cltype id ty env =
- store_cltype id (Pident id) ty env
+ store_cltype None id (Pident id) ty env env
let add_local_constraint id info elv env =
match info with
(* Insertion of bindings by name *)
let enter store_fun name data env =
- let id = Ident.create name in (id, store_fun id (Pident id) data env)
+ let id = Ident.create name in (id, store_fun None id (Pident id) data env env)
let enter_value ?check = enter (store_value ?check)
and enter_type = enter store_type
(* Open a signature path *)
-let open_signature root sg env =
+let open_signature slot root sg env0 =
(* First build the paths and substitution *)
- let (pl, sub) = prefix_idents root 0 Subst.identity sg in
+ let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
+ let sg = Lazy.force sg in
+
(* Then enter the components in the environment after substitution *)
+
let newenv =
List.fold_left2
(fun env item p ->
match item with
Sig_value(id, decl) ->
- let e1 = store_value (Ident.hide id) p
- (Subst.value_description sub decl) env
- in store_annot (Ident.hide id) p (Annot.Iref_external) e1
+ store_value slot (Ident.hide id) p decl env env0
| Sig_type(id, decl, _) ->
- store_type (Ident.hide id) p
- (Subst.type_declaration sub decl) env
+ store_type slot (Ident.hide id) p decl env env0
| Sig_exception(id, decl) ->
- store_exception (Ident.hide id) p
- (Subst.exception_declaration sub decl) env
+ store_exception slot (Ident.hide id) p decl env env0
| Sig_module(id, mty, _) ->
- store_module (Ident.hide id) p (Subst.modtype sub mty) env
+ store_module slot (Ident.hide id) p mty env env0
| Sig_modtype(id, decl) ->
- store_modtype (Ident.hide id) p
- (Subst.modtype_declaration sub decl) env
+ store_modtype slot (Ident.hide id) p decl env env0
| Sig_class(id, decl, _) ->
- store_class (Ident.hide id) p
- (Subst.class_declaration sub decl) env
+ store_class slot (Ident.hide id) p decl env env0
| Sig_class_type(id, decl, _) ->
- store_cltype (Ident.hide id) p
- (Subst.cltype_declaration sub decl) env)
- env sg pl in
- { newenv with summary = Env_open(env.summary, root) }
+ store_cltype slot (Ident.hide id) p decl env env0
+ )
+ env0 sg pl in
+ { newenv with summary = Env_open(env0.summary, root) }
(* Open a signature from a file *)
let open_pers_signature name env =
let ps = find_pers_struct name in
- open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
+ open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env
-let open_signature ?(loc = Location.none) ?(toplevel = false) root sg env =
- if not toplevel && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "")
+let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
+ if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
+ && (Warnings.is_active (Warnings.Unused_open "")
+ || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
+ || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
then begin
let used = ref false in
!add_delayed_check_forward
if not !used then
Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
);
- EnvTbl.with_slot used (open_signature root sg) env
+ let shadowed = ref [] in
+ let slot kind s b =
+ if b && not (List.mem (kind, s) !shadowed) then begin
+ shadowed := (kind, s) :: !shadowed;
+ let w =
+ match kind with
+ | "label" | "constructor" ->
+ Warnings.Open_shadow_label_constructor (kind, s)
+ | _ -> Warnings.Open_shadow_identifier (kind, s)
+ in
+ Location.prerr_warning loc w
+ end;
+ used := true
+ in
+ open_signature (Some slot) root sg env
end
- else open_signature root sg env
+ else open_signature None root sg env
(* Read a signature from a file *)
save_signature_with_imports sg modname filename (imported_units())
(* Folding on environments *)
-let ident_tbl_fold f t acc =
- List.fold_right
- (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc)
- (EnvTbl.keys t)
- acc
let find_all proj1 proj2 f lid env acc =
match lid with
| None ->
- ident_tbl_fold
+ EnvTbl.fold_name
(fun id (p, data) acc -> f (Ident.name id) p data acc)
(proj1 env) acc
| Some l ->
(fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc)
(proj2 c) acc
| Functor_comps _ ->
- raise Not_found
+ acc
+ end
+
+let find_all_simple_list proj1 proj2 f lid env acc =
+ match lid with
+ | None ->
+ EnvTbl.fold_name
+ (fun id data acc -> f data acc)
+ (proj1 env) acc
+ | Some l ->
+ let p, desc = lookup_module_descr l env in
+ begin match EnvLazy.force components_of_module_maker desc with
+ Structure_comps c ->
+ Tbl.fold
+ (fun s comps acc ->
+ match comps with
+ [] -> acc
+ | (data, pos) :: _ ->
+ f data acc)
+ (proj2 c) acc
+ | Functor_comps _ ->
+ acc
end
let fold_modules f lid env acc =
match lid with
| None ->
let acc =
- ident_tbl_fold
+ EnvTbl.fold_name
(fun id (p, data) acc -> f (Ident.name id) p data acc)
env.modules
acc
c.comp_modules
acc
| Functor_comps _ ->
- raise Not_found
+ acc
end
let fold_values f =
find_all (fun env -> env.values) (fun sc -> sc.comp_values) f
and fold_constructors f =
- find_all (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
+ find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
and fold_labels f =
- find_all (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+ find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
and fold_types f =
find_all (fun env -> env.types) (fun sc -> sc.comp_types) f
and fold_modtypes f =
(* Return the environment summary *)
let summary env = env.summary
+
+let last_env = ref empty
+let last_reduced_env = ref empty
+
let keep_only_summary env =
- { empty with
- summary = env.summary;
- local_constraints = env.local_constraints;
- in_signature = env.in_signature;
-}
+ if !last_env == env then !last_reduced_env
+ else begin
+ let new_env =
+ {
+ empty with
+ summary = env.summary;
+ local_constraints = env.local_constraints;
+ in_signature = env.in_signature;
+ }
+ in
+ last_env := env;
+ last_reduced_env := new_env;
+ new_env
+ end
+
let env_of_only_summary env_from_summary env =
let new_env = env_from_summary env.summary Subst.identity in
open Format
let report_error ppf = function
- | Illegal_renaming(modname, filename) -> fprintf ppf
- "Wrong file naming: %a@ contains the compiled interface for@ %s"
- Location.print_filename filename modname
+ | Illegal_renaming(name, modname, filename) -> fprintf ppf
+ "Wrong file naming: %a@ contains the compiled interface for @ %s when %s was expected"
+ Location.print_filename filename name modname
| Inconsistent_import(name, source1, source2) -> fprintf ppf
"@[<hov>The files %a@ and %a@ \
make inconsistent assumptions@ over interface %s@]"
(* *)
(***********************************************************************)
-(* $Id: env.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Environment handling *)
open Types
val initial: t
val diff: t -> t -> Ident.t list
+type type_descriptions =
+ constructor_description list * label_description list
+
+(* For short-paths *)
+val iter_types:
+ (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) ->
+ t -> unit
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+
(* Lookup by paths *)
val find_value: Path.t -> t -> value_description
-val find_annot: Path.t -> t -> Annot.ident
val find_type: Path.t -> t -> type_declaration
-val find_constructors: Path.t -> t -> constructor_description list
+val find_type_descrs: Path.t -> t -> type_descriptions
val find_module: Path.t -> t -> module_type
val find_modtype: Path.t -> t -> modtype_declaration
val find_class: Path.t -> t -> class_declaration
Path.t -> t -> type_expr list * type_expr * int option
(* Find the manifest type information associated to a type for the sake
of the compiler's type-based optimisations. *)
-val find_modtype_expansion: Path.t -> t -> Types.module_type
+val find_modtype_expansion: Path.t -> t -> module_type
val has_local_constraints: t -> bool
val add_gadt_instance_level: int -> t -> t
(* Lookup by long identifiers *)
val lookup_value: Longident.t -> t -> Path.t * value_description
-val lookup_annot: Longident.t -> t -> Path.t * Annot.ident
-val lookup_constructor: Longident.t -> t -> Path.t * constructor_description
-val lookup_label: Longident.t -> t -> Path.t * label_description
+val lookup_constructor: Longident.t -> t -> constructor_description
+val lookup_all_constructors:
+ Longident.t -> t -> (constructor_description * (unit -> unit)) list
+val lookup_label: Longident.t -> t -> label_description
+val lookup_all_labels:
+ Longident.t -> t -> (label_description * (unit -> unit)) list
val lookup_type: Longident.t -> t -> Path.t * type_declaration
val lookup_module: Longident.t -> t -> Path.t * module_type
val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
val lookup_class: Longident.t -> t -> Path.t * class_declaration
val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration
+exception Recmodule
+ (* Raise by lookup_module when the identifier refers
+ to one of the modules of a recursive definition
+ during the computation of its approximation (see #5965). *)
+
(* Insertion by identifier *)
val add_value:
?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
-val add_annot: Ident.t -> Annot.ident -> t -> t
val add_type: Ident.t -> type_declaration -> t -> t
val add_exception: Ident.t -> exception_declaration -> t -> t
val add_module: Ident.t -> module_type -> t -> t
(* Insertion of all fields of a signature, relative to the given path.
Used to implement open. *)
-val open_signature: ?loc:Location.t -> ?toplevel:bool -> Path.t -> signature -> t -> t
+val open_signature:
+ ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
+ signature -> t -> t
val open_pers_signature: string -> t -> t
(* Insertion by name *)
(* Initialize the cache of in-core module interfaces. *)
val reset_cache: unit -> unit
-val reset_missing_cmis: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
(* Remember the name of the current compilation unit. *)
val set_unit_name: string -> unit
val keep_only_summary : t -> t
val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
-
(* Error report *)
type error =
- | Illegal_renaming of string * string
+ | Illegal_renaming of string * string * string
| Inconsistent_import of string * string * string
| Need_recursive_types of string * string
(** Folding over all identifiers (for analysis purpose) *)
val fold_values:
- (string -> Path.t -> Types.value_description -> 'a -> 'a) ->
+ (string -> Path.t -> value_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_types:
- (string -> Path.t -> Types.type_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_constructors:
- (string -> Path.t -> Types.constructor_description -> 'a -> 'a) ->
+ (constructor_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_labels:
- (string -> Path.t -> Types.label_description -> 'a -> 'a) ->
+ (label_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
(** Persistent structures are only traversed if they are already loaded. *)
val fold_modules:
- (string -> Path.t -> Types.module_type -> 'a -> 'a) ->
+ (string -> Path.t -> module_type -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_modtypes:
- (string -> Path.t -> Types.modtype_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_classs:
- (string -> Path.t -> Types.class_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> class_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_cltypes:
- (string -> Path.t -> Types.class_type_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
+(* OCaml port by John Malecki and Xavier Leroy *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Misc
+open Types
+open Env
+
+type error =
+ Module_not_found of Path.t
+
+exception Error of error
+
+let env_cache =
+ (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
+
+let reset_cache () =
+ Hashtbl.clear env_cache;
+ Env.reset_cache()
+
+let extract_sig env mty =
+ match Mtype.scrape env mty with
+ Mty_signature sg -> sg
+ | _ -> fatal_error "Envaux.extract_sig"
+
+let rec env_from_summary sum subst =
+ try
+ Hashtbl.find env_cache (sum, subst)
+ with Not_found ->
+ let env =
+ match sum with
+ Env_empty ->
+ Env.empty
+ | Env_value(s, id, desc) ->
+ Env.add_value id (Subst.value_description subst desc)
+ (env_from_summary s subst)
+ | Env_type(s, id, desc) ->
+ Env.add_type id (Subst.type_declaration subst desc)
+ (env_from_summary s subst)
+ | Env_exception(s, id, desc) ->
+ Env.add_exception id (Subst.exception_declaration subst desc)
+ (env_from_summary s subst)
+ | Env_module(s, id, desc) ->
+ Env.add_module id (Subst.modtype subst desc)
+ (env_from_summary s subst)
+ | Env_modtype(s, id, desc) ->
+ Env.add_modtype id (Subst.modtype_declaration subst desc)
+ (env_from_summary s subst)
+ | Env_class(s, id, desc) ->
+ Env.add_class id (Subst.class_declaration subst desc)
+ (env_from_summary s subst)
+ | Env_cltype (s, id, desc) ->
+ Env.add_cltype id (Subst.cltype_declaration subst desc)
+ (env_from_summary s subst)
+ | Env_open(s, path) ->
+ let env = env_from_summary s subst in
+ let path' = Subst.module_path subst path in
+ let mty =
+ try
+ Env.find_module path' env
+ with Not_found ->
+ raise (Error (Module_not_found path'))
+ in
+ Env.open_signature Asttypes.Override path' (extract_sig env mty) env
+ in
+ Hashtbl.add env_cache (sum, subst) env;
+ env
+
+let env_of_only_summary env =
+ Env.env_of_only_summary env_from_summary env
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+ | Module_not_found p ->
+ fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
+(* OCaml port by John Malecki and Xavier Leroy *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Format
+
+(* Convert environment summaries to environments *)
+
+val env_from_summary : Env.summary -> Subst.t -> Env.t
+
+(* Empty the environment caches. To be called when load_path changes. *)
+
+val reset_cache: unit -> unit
+
+val env_of_only_summary : Env.t -> Env.t
+
+(* Error report *)
+
+type error =
+ Module_not_found of Path.t
+
+exception Error of error
+
+val report_error: formatter -> error -> unit
(* *)
(***********************************************************************)
-(* $Id: ident.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Format
type t = { stamp: int; name: string; mutable flags: int }
else
find_name name (if c < 0 then l else r)
-let rec keys_aux stack accu = function
+let rec get_all = function
+ | None -> []
+ | Some k -> k.data :: get_all k.previous
+
+let rec find_all name = function
+ Empty ->
+ []
+ | Node(l, k, r, _) ->
+ let c = compare name k.ident.name in
+ if c = 0 then
+ k.data :: get_all k.previous
+ else
+ find_all name (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
Empty ->
begin match stack with
[] -> accu
- | a :: l -> keys_aux l accu a
+ | a :: l -> fold_aux f l accu a
end
| Node(l, k, r, _) ->
- keys_aux (l :: stack) (k.ident :: accu) r
+ fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+ match d with
+ None -> accu
+ | Some k -> f k.ident k.data (fold_data f k.previous accu)
-let keys tbl = keys_aux [] [] tbl
+let fold_all f tbl accu =
+ fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+ Empty -> ()
+ | Node(l, k, r, _) ->
+ iter f l; f k.ident k.data; iter f r
(* *)
(***********************************************************************)
-(* $Id: ident.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Identifiers (unique names) *)
type t = { stamp: int; name: string; mutable flags: int }
val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> 'a
-val keys: 'a tbl -> t list
+val find_all: string -> 'a tbl -> 'a list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
(* *)
(***********************************************************************)
-(* $Id: includeclass.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Inclusion checks for the class language *)
open Types
| CM_Parameter_arity_mismatch (ls, lp) ->
fprintf ppf
"The classes do not have the same number of type parameters"
- | CM_Type_parameter_mismatch trace ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error false trace
+ | CM_Type_parameter_mismatch (env, trace) ->
+ Printtyp.report_unification_error ppf env ~unif:false trace
(function ppf ->
- fprintf ppf "A type parameter has type"))
+ fprintf ppf "A type parameter has type")
(function ppf ->
fprintf ppf "but is expected to have type")
- | CM_Class_type_mismatch (cty1, cty2) ->
- fprintf ppf
- "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]"
- Printtyp.class_type cty1 Printtyp.class_type cty2
- | CM_Parameter_mismatch trace ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error false trace
+ | CM_Class_type_mismatch (env, cty1, cty2) ->
+ Printtyp.wrap_printing_env env (fun () ->
+ fprintf ppf
+ "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+ Printtyp.class_type cty1
+ "is not matched by the class type"
+ Printtyp.class_type cty2)
+ | CM_Parameter_mismatch (env, trace) ->
+ Printtyp.report_unification_error ppf env ~unif:false trace
(function ppf ->
- fprintf ppf "A parameter has type"))
+ fprintf ppf "A parameter has type")
(function ppf ->
fprintf ppf "but is expected to have type")
- | CM_Val_type_mismatch (lab, trace) ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error false trace
+ | CM_Val_type_mismatch (lab, env, trace) ->
+ Printtyp.report_unification_error ppf env ~unif:false trace
(function ppf ->
- fprintf ppf "The instance variable %s@ has type" lab))
+ fprintf ppf "The instance variable %s@ has type" lab)
(function ppf ->
fprintf ppf "but is expected to have type")
- | CM_Meth_type_mismatch (lab, trace) ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error false trace
+ | CM_Meth_type_mismatch (lab, env, trace) ->
+ Printtyp.report_unification_error ppf env ~unif:false trace
(function ppf ->
- fprintf ppf "The method %s@ has type" lab))
+ fprintf ppf "The method %s@ has type" lab)
(function ppf ->
fprintf ppf "but is expected to have type")
| CM_Non_mutable_value lab ->
(* *)
(***********************************************************************)
-(* $Id: includeclass.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Inclusion checks for the class language *)
open Types
(* *)
(***********************************************************************)
-(* $Id: includecore.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Inclusion checks for the core language *)
-open Misc
open Asttypes
open Path
open Types
| Field_missing of bool * Ident.t
| Record_representation of bool
-let nth n =
- if n = 1 then "first" else
- if n = 2 then "2nd" else
- if n = 3 then "3rd" else
- string_of_int n ^ "th"
-
let report_type_mismatch0 first second decl ppf err =
let pr fmt = Format.fprintf ppf fmt in
match err with
| Field_arity s ->
pr "The arities for field %s differ" (Ident.name s)
| Field_names (n, name1, name2) ->
- pr "Their %s fields have different names, %s and %s"
- (nth n) (Ident.name name1) (Ident.name name2)
+ pr "Fields number %i have different names, %s and %s"
+ n (Ident.name name1) (Ident.name name2)
| Field_missing (b, s) ->
pr "The field %s is only present in %s %s"
(Ident.name s) (if b then second else first) decl
else [Constraint]
in
if err <> [] then err else
- if match decl2.type_kind with
- | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private
- | Type_abstract ->
- match decl2.type_manifest with
- | None -> true
- | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty)
- then
- if List.for_all2
- (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2)&&(not cn1 || cn2))
- decl1.type_variance decl2.type_variance
- then [] else [Variance]
- else []
+ let abstr =
+ decl2.type_private = Private ||
+ decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+ if List.for_all2
+ (fun ty (v1,v2) ->
+ let open Variance in
+ let imp a b = not a || b in
+ let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+ imp abstr (imp co1 co2 && imp cn1 cn2) &&
+ (abstr || Btype.(is_Tvar (repr ty)) || co1 = co2 && cn1 = cn2) &&
+ let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+ imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+ decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+ then [] else [Variance]
(* Inclusion between exception declarations *)
(* *)
(***********************************************************************)
-(* $Id: includecore.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Inclusion checks for the core language *)
open Typedtree
(* *)
(***********************************************************************)
-(* $Id: includemod.ml 12520 2012-05-31 07:41:37Z garrigue $ *)
-
(* Inclusion checks for the module language *)
open Misc
type pos =
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-type error = pos list * symptom
+type error = pos list * Env.t * symptom
exception Error of error list
try
Includecore.value_descriptions env vd1 vd2
with Includecore.Dont_match ->
- raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
+ raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])
(* Inclusion between type declarations *)
Env.mark_type_used (Ident.name id) decl1;
let decl2 = Subst.type_declaration subst decl2 in
let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in
- if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
+ if err <> [] then
+ raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)])
(* Inclusion between exception declarations *)
let decl2 = Subst.exception_declaration subst decl2 in
if Includecore.exception_declarations env decl1 decl2
then ()
- else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
+ else raise(Error[cxt, env, Exception_declarations(id, decl1, decl2)])
(* Inclusion between class declarations *)
match Includeclass.class_type_declarations env decl1 decl2 with
[] -> ()
| reason ->
- raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
+ raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)])
let class_declarations env cxt subst id decl1 decl2 =
let decl2 = Subst.class_declaration subst decl2 in
match Includeclass.class_declarations env decl1 decl2 with
[] -> ()
- | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
+ | reason ->
+ raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)])
(* Expand a module type identifier when possible *)
try
Env.find_modtype_expansion path env
with Not_found ->
- raise(Error[cxt, Unbound_modtype_path path])
+ raise(Error[cxt, env, Unbound_modtype_path path])
(* Extract name, kind and ident from a signature item *)
| Sig_class(id, _, _) -> (id, Field_class(Ident.name id))
| Sig_class_type(id, _, _) -> (id, Field_classtype(Ident.name id))
+let is_runtime_component = function
+ | Sig_value(_,{val_kind = Val_prim _})
+ | Sig_type(_,_,_)
+ | Sig_modtype(_,_)
+ | Sig_class_type(_,_,_) -> false
+ | Sig_value(_,_)
+ | Sig_exception(_,_)
+ | Sig_module(_,_,_)
+ | Sig_class(_, _,_) -> true
+
(* Simplify a structure coercion *)
let simplify_structure_coercion cc =
try_modtypes env cxt subst mty1 mty2
with
Dont_match ->
- raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
+ raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
| Error reasons ->
- raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
+ raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
:: reasons))
and try_modtypes env cxt subst mty1 mty2 =
(* Build a table of the components of sig1, along with their positions.
The table is indexed by kind and name of component *)
let rec build_component_table pos tbl = function
- [] -> tbl
+ [] -> pos, tbl
| item :: rem ->
let (id, name) = item_ident_name item in
- let nextpos =
- match item with
- Sig_value(_,{val_kind = Val_prim _})
- | Sig_type(_,_,_)
- | Sig_modtype(_,_)
- | Sig_class_type(_,_,_) -> pos
- | Sig_value(_,_)
- | Sig_exception(_,_)
- | Sig_module(_,_,_)
- | Sig_class(_, _,_) -> pos+1 in
+ let nextpos = if is_runtime_component item then pos + 1 else pos in
build_component_table nextpos
(Tbl.add name (id, item, pos) tbl) rem in
- let comps1 =
+ let len1, comps1 =
build_component_table 0 Tbl.empty sig1 in
+ let len2 =
+ List.fold_left
+ (fun n i -> if is_runtime_component i then n + 1 else n)
+ 0
+ sig2
+ in
(* Pair each component of sig2 with a component of sig1,
identifying the names along the way.
Return a coercion list indicating, for all run-time components
let rec pair_components subst paired unpaired = function
[] ->
begin match unpaired with
- [] -> signature_components new_env cxt subst (List.rev paired)
+ [] ->
+ let cc =
+ signature_components new_env cxt subst (List.rev paired)
+ in
+ if len1 = len2 then (* see PR#5098 *)
+ simplify_structure_coercion cc
+ else
+ Tcoerce_structure cc
| _ -> raise(Error unpaired)
end
| item2 :: rem ->
((item1, item2, pos1) :: paired) unpaired rem
with Not_found ->
let unpaired =
- if report then (cxt, Missing_field id2) :: unpaired else unpaired in
+ if report then (cxt, env, Missing_field id2) :: unpaired
+ else unpaired in
pair_components subst paired unpaired rem
end in
(* Do the pairing and checking, and return the final coercion *)
- simplify_structure_coercion (pair_components subst [] [] sig2)
+ pair_components subst [] [] sig2
(* Inclusion between signature components *)
| (Modtype_abstract, Modtype_manifest mty2) ->
check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2
with Error reasons ->
- raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
+ raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
and check_modtype_equiv env cxt mty1 mty2 =
match
modtypes env cxt Subst.identity mty2 mty1)
with
(Tcoerce_none, Tcoerce_none) -> ()
- | (_, _) -> raise(Error [cxt, Modtype_permutation])
+ | (_, _) -> raise(Error [cxt, env, Modtype_permutation])
(* Simplified inclusion check between module types (for Env) *)
try
signatures Env.initial [] Subst.identity impl_sig intf_sig
with Error reasons ->
- raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
+ raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
+ :: reasons))
(* Hide the context and substitution parameters to the outside world *)
else
fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
-let include_err ppf (cxt, err) =
- fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
+let include_err ppf (cxt, env, err) =
+ Printtyp.wrap_printing_env env (fun () ->
+ fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err)
let buffer = ref ""
let is_big obj =
if errs = [] then () else
let (errs , err) = split_last errs in
let pe = ref true in
- let include_err' ppf err =
- if not (is_big err) then fprintf ppf "%a@ " include_err err
+ let include_err' ppf (_,_,obj as err) =
+ if not (is_big obj) then fprintf ppf "%a@ " include_err err
else if !pe then (fprintf ppf "...@ "; pe := false)
in
let print_errs ppf = List.iter (include_err' ppf) in
(* *)
(***********************************************************************)
-(* $Id: includemod.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Inclusion checks for the module language *)
open Typedtree
type pos =
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-type error = pos list * symptom
+type error = pos list * Env.t * symptom
exception Error of error list
(* *)
(***********************************************************************)
-(* $Id: mtype.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Operations on module types *)
open Asttypes
(* *)
(***********************************************************************)
-(* $Id: mtype.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Operations on module types *)
open Types
(* *)
(***********************************************************************)
-(* $Id: oprint.ml 11964 2011-12-28 02:22:38Z garrigue $ *)
-
open Format
open Outcometree
let rec print_ident ppf =
function
- Oide_ident s -> fprintf ppf "%s" s
- | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
+ Oide_ident s -> pp_print_string ppf s
+ | Oide_dot (id, s) ->
+ print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s
| Oide_apply (id1, id2) ->
fprintf ppf "%a(%a)" print_ident id1 print_ident id2
if parenthesized_ident name then
fprintf ppf "( %s )" name
else
- fprintf ppf "%s" name
+ pp_print_string ppf name
(* Values *)
| Oval_int32 i -> fprintf ppf "%lil" i
| Oval_int64 i -> fprintf ppf "%LiL" i
| Oval_nativeint i -> fprintf ppf "%nin" i
- | Oval_float f -> fprintf ppf "%s" (float_repres f)
+ | Oval_float f -> pp_print_string ppf (float_repres f)
| Oval_char c -> fprintf ppf "%C" c
| Oval_string s ->
begin try fprintf ppf "%S" s with
fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
| Oval_constr (name, []) -> print_ident ppf name
| Oval_variant (name, None) -> fprintf ppf "`%s" name
- | Oval_stuff s -> fprintf ppf "%s" s
+ | Oval_stuff s -> pp_print_string ppf s
| Oval_record fel ->
fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
| Oval_ellipsis -> raise Ellipsis
and print_out_type_1 ppf =
function
Otyp_arrow (lab, ty1, ty2) ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty1 print_out_type_1 ty2
+ pp_open_box ppf 0;
+ if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+ print_out_type_2 ppf ty1;
+ pp_print_string ppf " ->";
+ pp_print_space ppf ();
+ print_out_type_1 ppf ty2;
+ pp_close_box ppf ()
| ty -> print_out_type_2 ppf ty
and print_out_type_2 ppf =
function
fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
print_ident id
| Otyp_constr (id, tyl) ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+ pp_open_box ppf 0;
+ print_typargs ppf tyl;
+ print_ident ppf id;
+ pp_close_box ppf ()
| Otyp_object (fields, rest) ->
fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
- | Otyp_stuff s -> fprintf ppf "%s" s
+ | Otyp_stuff s -> pp_print_string ppf s
| Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
| Otyp_variant (non_gen, row_fields, closed, tags) ->
let print_present ppf =
print_fields row_fields
print_present tags
| Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
- fprintf ppf "@[<1>(%a)@]" print_out_type ty
+ pp_open_box ppf 1;
+ pp_print_char ppf '(';
+ print_out_type ppf ty;
+ pp_print_char ppf ')';
+ pp_close_box ppf ()
| Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
| Otyp_module (p, n, tyl) ->
fprintf ppf "@[<1>(module %s" p;
[] -> ()
| [ty] -> print_elem ppf ty
| ty :: tyl ->
- fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
- tyl
+ print_elem ppf ty;
+ pp_print_string ppf sep;
+ pp_print_space ppf ();
+ print_typlist print_elem sep ppf tyl
and print_typargs ppf =
function
[] -> ()
- | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
- | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl
+ | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+ | tyl ->
+ pp_open_box ppf 1;
+ pp_print_char ppf '(';
+ print_typlist print_out_type "," ppf tyl;
+ pp_print_char ppf ')';
+ pp_close_box ppf ();
+ pp_print_space ppf ()
let out_type = ref print_out_type
in
let type_defined ppf =
match args with
- [] -> fprintf ppf "%s" name
+ [] -> pp_print_string ppf name
| [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
| _ ->
fprintf ppf "@[(@[%a)@]@ %s@]"
let print_private ppf = function
Asttypes.Private -> fprintf ppf " private"
| Asttypes.Public -> () in
- let rec print_out_tkind ppf = function
+ let print_out_tkind ppf = function
| Otyp_abstract -> ()
| Otyp_record lbls ->
fprintf ppf " =%a {%a@;<1 -2>}"
| None ->
begin match tyl with
| [] ->
- fprintf ppf "%s" name
+ pp_print_string ppf name
| _ ->
fprintf ppf "@[<2>%s of@ %a@]" name
(print_typlist print_simple_out_type " *") tyl
(* *)
(***********************************************************************)
-(* $Id: oprint.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
open Format
open Outcometree
(* *)
(***********************************************************************)
-(* $Id: outcometree.mli 11160 2011-07-29 10:32:43Z garrigue $ *)
-
(* Module [Outcometree]: results displayed by the toplevel *)
(* These types represent messages that the toplevel displays as normal
(* *)
(***********************************************************************)
-(* $Id: parmatch.ml 12961 2012-09-27 13:30:07Z garrigue $ *)
-
(* Detection of partial matches and unused match cases. *)
open Misc
(* Invariant: fields are already sorted by Typecore.type_label_a_list *)
let rec combine r1 r2 l1 l2 = match l1,l2 with
| [],[] -> List.rev r1, List.rev r2
- | [],(_,_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
- | (_,_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
- | (_,_,lbl1,p1)::rem1, (_, _,lbl2,p2)::rem2 ->
+ | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+ | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+ | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
combine (p1::r1) (omega::r2) rem1 l2
else if lbl1.lbl_pos > lbl2.lbl_pos then
| Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_lazy p, Tpat_lazy q -> compat p q
- | Tpat_construct (_, _, c1,ps1, _), Tpat_construct (_, _, c2,ps2, _) ->
+ | Tpat_construct (_, c1,ps1, _), Tpat_construct (_, c2,ps2, _) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
| Tconstr (path,_,_) -> path
| _ -> fatal_error "Parmatch.get_type_path"
-let rec get_type_descr ty tenv =
+let get_type_descr ty tenv =
match (Ctype.repr ty).desc with
| Tconstr (path,_,_) -> Env.find_type path tenv
| _ -> fatal_error "Parmatch.get_type_descr"
| "::" -> true
| _ -> false
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string s -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
let rec pretty_val ppf v =
match v.pat_extra with
match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
| Tpat_var (x,_) -> Ident.print ppf x
- | Tpat_constant (Const_int i) -> fprintf ppf "%d" i
- | Tpat_constant (Const_char c) -> fprintf ppf "%C" c
- | Tpat_constant (Const_string s) -> fprintf ppf "%S" s
- | Tpat_constant (Const_float f) -> fprintf ppf "%s" f
- | Tpat_constant (Const_int32 i) -> fprintf ppf "%ldl" i
- | Tpat_constant (Const_int64 i) -> fprintf ppf "%LdL" i
- | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
+ | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
| Tpat_tuple vs ->
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
- | Tpat_construct (_, _, {cstr_tag=tag},[], _) ->
+ | Tpat_construct (_, {cstr_tag=tag},[], _) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "%s" name
- | Tpat_construct (_, _, {cstr_tag=tag},[w], _) ->
+ | Tpat_construct (_, {cstr_tag=tag},[w], _) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
- | Tpat_construct (_, _, {cstr_tag=tag},vs, _) ->
+ | Tpat_construct (_, {cstr_tag=tag},vs, _) ->
let name = get_constr_name tag v.pat_type v.pat_env in
begin match (name, vs) with
("::", [v1;v2]) ->
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
(List.filter
(function
- | (_,_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+ | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
| _ -> true) lvs)
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
and pretty_car ppf v = match v.pat_desc with
-| Tpat_construct (_,_,{cstr_tag=tag}, [_ ; _], _)
+| Tpat_construct (_,{cstr_tag=tag}, [_ ; _], _)
when is_cons tag v ->
fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct (_,_,{cstr_tag=tag}, [v1 ; v2], _)
+| Tpat_construct (_,{cstr_tag=tag}, [v1 ; v2], _)
when is_cons tag v ->
fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
| _ -> pretty_val ppf v
and pretty_arg ppf v = match v.pat_desc with
-| Tpat_construct (_,_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v
+| Tpat_construct (_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_or ppf v = match v.pat_desc with
and pretty_lvals lbls ppf = function
| [] -> ()
- | [_, _,lbl,v] ->
+ | [_,lbl,v] ->
let name = find_label lbl lbls in
fprintf ppf "%s=%a" (Ident.name name) pretty_val v
- | (_, _, lbl,v)::rest ->
+ | (_, lbl,v)::rest ->
let name = find_label lbl lbls in
fprintf ppf "%s=%a;@ %a"
(Ident.name name) pretty_val v (pretty_lvals lbls) rest
fprintf ppf "@[%a@]@?" pretty_val v
-let prerr_pat v =
- top_pretty str_formatter v ;
- prerr_string (flush_str_formatter ())
+let pretty_pat p =
+ top_pretty Format.str_formatter p ;
+ prerr_string (Format.flush_str_formatter ())
+
+type matrix = pattern list list
+
+let pretty_line ps =
+ List.iter
+ (fun p ->
+ top_pretty Format.str_formatter p ;
+ prerr_string " <" ;
+ prerr_string (Format.flush_str_formatter ()) ;
+ prerr_string ">")
+ ps
+
+let pretty_matrix (pss : matrix) =
+ prerr_endline "begin matrix" ;
+ List.iter
+ (fun ps ->
+ pretty_line ps ;
+ prerr_endline "")
+ pss ;
+ prerr_endline "end matrix"
(****************************)
(* Check top matching *)
let simple_match p1 p2 =
match p1.pat_desc, p2.pat_desc with
- | Tpat_construct(_, _, c1, _, _), Tpat_construct(_,_, c2, _, _) ->
+ | Tpat_construct(_, c1, _, _), Tpat_construct(_, c2, _, _) ->
c1.cstr_tag = c2.cstr_tag
| Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
l1 = l2
(* Raise Not_found when pos is not present in arg *)
let get_field pos arg =
- let _,_,_, p = List.find (fun (_,_,lbl,_) -> pos = lbl.lbl_pos) arg in
+ let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in
p
let extract_fields omegas arg =
List.map
- (fun (_,_,lbl,_) ->
+ (fun (_,lbl,_) ->
try
get_field lbl.lbl_pos arg
with Not_found -> omega)
omegas
let all_record_args lbls = match lbls with
-| (_,_,{lbl_all=lbl_all},_)::_ ->
+| (_,{lbl_all=lbl_all},_)::_ ->
let t =
Array.map
- (fun lbl -> Path.Pident (Ident.create "?temp?"),
- mknoloc (Longident.Lident "?temp?"), lbl,omega)
+ (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
lbl_all in
List.iter
- (fun ((_,_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
+ (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
lbls ;
Array.to_list t
| _ -> fatal_error "Parmatch.all_record_args"
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
-| Tpat_construct(_,_, cstr, args, _) -> args
+| Tpat_construct(_, cstr, args, _) -> args
| Tpat_variant(lab, Some arg, _) -> [arg]
| Tpat_tuple(args) -> args
| Tpat_record(args,_) -> extract_fields (record_arg p1) args
| Tpat_lazy arg -> [arg]
| (Tpat_any | Tpat_var(_)) ->
begin match p1.pat_desc with
- Tpat_construct(_,_, _,args, _) -> omega_list args
+ Tpat_construct(_, _,args, _) -> omega_list args
| Tpat_variant(_, Some _, _) -> [omega]
| Tpat_tuple(args) -> omega_list args
| Tpat_record(args,_) -> omega_list args
| Tpat_alias (p,_,_) -> normalize_pat p
| Tpat_tuple (args) ->
make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
- | Tpat_construct (lid, lid_loc, c,args,explicit_arity) ->
+ | Tpat_construct (lid, c,args,explicit_arity) ->
make_pat
- (Tpat_construct (lid, lid_loc, c,omega_list args, explicit_arity))
+ (Tpat_construct (lid, c,omega_list args, explicit_arity))
q.pat_type q.pat_env
| Tpat_variant (l, arg, row) ->
make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env
| Tpat_record (largs, closed) ->
make_pat
- (Tpat_record (List.map (fun (lid,lid_loc,lbl,_) ->
- lid, lid_loc, lbl,omega) largs, closed))
+ (Tpat_record (List.map (fun (lid,lbl,_) ->
+ lid, lbl,omega) largs, closed))
q.pat_type q.pat_env
| Tpat_lazy _ ->
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
| (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
let new_omegas =
List.fold_right
- (fun (lid, lid_loc, lbl,_) r ->
+ (fun (lid, lbl,_) r ->
try
let _ = get_field lbl.lbl_pos r in
r
with Not_found ->
- (lid, lid_loc, lbl,omega)::r)
+ (lid, lbl,omega)::r)
largs (record_arg acc)
in
acc_pat
let args,rest = read_args omegas r in
make_pat
(Tpat_record
- (List.map2 (fun (lid, lid_loc, lbl,_) arg ->
+ (List.map2 (fun (lid, lbl,_) arg ->
if
erase_mutable &&
(match lbl.lbl_mut with
| Mutable -> true | Immutable -> false)
then
- lid, lid_loc, lbl, omega
+ lid, lbl, omega
else
- lid, lid_loc, lbl, arg)
+ lid, lbl, arg)
omegas args, closed))
q.pat_type q.pat_env::
rest
-| {pat_desc = Tpat_construct (lid, lid_loc, c,omegas, explicit_arity)} ->
+| {pat_desc = Tpat_construct (lid, c,omegas, explicit_arity)} ->
let args,rest = read_args omegas r in
make_pat
- (Tpat_construct (lid, lid_loc, c,args, explicit_arity))
+ (Tpat_construct (lid, c,args, explicit_arity))
q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
let generalized_constructor x =
match x with
- ({pat_desc = Tpat_construct(_,_,c,_, _);pat_env=env},_) ->
+ ({pat_desc = Tpat_construct(_,c,_, _);pat_env=env},_) ->
c.cstr_generalized
| _ -> assert false
loop env
let full_match ignore_generalized closing env = match env with
-| ({pat_desc = Tpat_construct (_,_,{cstr_tag=Cstr_exception _},_,_)},_)::_ ->
+| ({pat_desc = Tpat_construct (_,{cstr_tag=Cstr_exception _},_,_)},_)::_ ->
false
-| ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ ->
+| ({pat_desc = Tpat_construct(_,c,_,_);pat_type=typ},_) :: _ ->
if ignore_generalized then
(* remove generalized constructors;
those cases will be handled separately *)
| _ -> fatal_error "Parmatch.full_match"
let full_match_gadt env = match env with
- | ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ ->
+ | ({pat_desc = Tpat_construct(_,c,_,_);pat_type=typ},_) :: _ ->
List.length env = c.cstr_consts + c.cstr_nonconsts
| _ -> true
let extendable_match env = match env with
-| ({pat_desc=Tpat_construct(_,_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
+| ({pat_desc=Tpat_construct(_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
as p,_) :: _ ->
let path = get_type_path p.pat_type p.pat_env in
not
| None -> false
| Some ext -> match env with
| ({pat_desc =
- Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
+ Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
as p, _) :: _ ->
let path = get_type_path p.pat_type p.pat_env in
Path.same path ext
(* build a pattern from a constructor list *)
let pat_of_constr ex_pat cstr =
{ex_pat with pat_desc =
- Tpat_construct (Path.Pident (Ident.create "?pat_of_constr?"),
- mknoloc (Longident.Lident "?pat_of_constr?"),
+ Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
cstr,omegas cstr.cstr_arity,false)}
let rec pat_of_constrs ex_pat = function
(* Sends back a pattern that complements constructor tags all_tag *)
let complete_constrs p all_tags =
match p.pat_desc with
- | Tpat_construct (_,_,c,_,_) ->
+ | Tpat_construct (_,c,_,_) ->
begin try
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
- let constrs =
- Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in
+ let (constrs, _) =
+ Env.find_type_descrs (adt_path p.pat_env p.pat_type) p.pat_env in
map_filter
(fun cnstr ->
if List.mem cnstr.cstr_tag not_tags then Some cnstr else None)
let build_other ext env = match env with
| ({pat_desc =
- Tpat_construct (lid, lid_loc, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
+ Tpat_construct (lid, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
::_ ->
make_pat
(Tpat_construct
- (lid, lid_loc, {c with
+ (lid, {c with
cstr_tag=(Cstr_exception
(Path.Pident (Ident.create "*exception*"), Location.none))},
[], false))
Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_,_, _,_,_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct (_, _,_,_)} as p,_) :: _ ->
begin match ext with
| Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
extra_pat
| _ ->
let get_tag = function
- | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag
+ | {pat_desc = Tpat_construct (_,c,_,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
pat_of_constrs p (complete_constrs p all_tags)
match env with
| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
let get_tag = function
- | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag
+ | {pat_desc = Tpat_construct (_,c,_,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
let cnstrs = complete_constrs p all_tags in
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
| Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
| Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
- | Tpat_construct (_, _,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
+ | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
has_instances ps
- | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,_,x) -> x) lps)
+ | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
| Tpat_lazy p
-> has_instance p
| Rsome of 'a (* This matching value *)
let rec orify_many =
- let rec orify x y =
+ let orify x y =
make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
in
function
| Rnone -> try_many f rest
| r -> r
+let rappend r1 r2 =
+ match r1, r2 with
+ | Rnone, _ -> r2
+ | _, Rnone -> r1
+ | Rsome l1, Rsome l2 -> Rsome (l1 @ l2)
let rec try_many_gadt f = function
| [] -> Rnone
| (p,pss)::rest ->
- match f (p,pss) with
- | Rnone -> try_many f rest
- | Rsome sofar ->
- let others = try_many f rest in
- match others with
- Rnone -> Rsome sofar
- | Rsome sofar' ->
- Rsome (sofar @ sofar')
-
-
+ rappend (f (p, pss)) (try_many_gadt f rest)
let rec exhaust ext pss n = match pss with
| [] -> Rsome (omegas n)
| Rsome r ->
try
let missing_trailing = build_other_gadt ext constrs in
- let before =
- match before with
- Rnone -> []
- | Rsome lst -> lst
- in
let dug =
combinations
(fun head tail -> head :: tail)
missing_trailing
r
in
- Rsome (dug @ before)
+ match before with
+ | Rnone -> Rsome dug
+ | Rsome x -> Rsome (x @ dug)
with
(* cannot occur, since constructors don't make a full signature *)
| Empty -> fatal_error "Parmatch.exhaust"
| Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *)
-let pretty_pat p =
- top_pretty Format.str_formatter p ;
- prerr_string (Format.flush_str_formatter ())
-
-type matrix = pattern list list
-
-let pretty_line ps =
- List.iter
- (fun p ->
- top_pretty Format.str_formatter p ;
- prerr_string " <" ;
- prerr_string (Format.flush_str_formatter ()) ;
- prerr_string ">")
- ps
-
-let pretty_matrix pss =
- prerr_endline "begin matrix" ;
- List.iter
- (fun ps ->
- pretty_line ps ;
- prerr_endline "")
- pss ;
- prerr_endline "end matrix"
(* this row type enable column processing inside the matrix
- left -> elements not to be processed,
| Tpat_alias(p,_,_), _ -> le_pat p q
| _, Tpat_alias(q,_,_) -> le_pat p q
| Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
- | Tpat_construct(_,_,c1,ps,_), Tpat_construct(_,_,c2,qs,_) ->
+ | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
(l1 = l2 && le_pat p1 p2)
| Tpat_lazy p, Tpat_lazy q ->
let r = lub p q in
make_pat (Tpat_lazy r) p.pat_type p.pat_env
-| Tpat_construct (lid, lid_loc, c1,ps1,_), Tpat_construct (_, _,c2,ps2,_)
+| Tpat_construct (lid, c1,ps1,_), Tpat_construct (_,c2,ps2,_)
when c1.cstr_tag = c2.cstr_tag ->
let rs = lubs ps1 ps2 in
- make_pat (Tpat_construct (lid, lid_loc, c1,rs, false))
+ make_pat (Tpat_construct (lid, c1,rs, false))
p.pat_type p.pat_env
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
when l1=l2 ->
let rec lub_rec l1 l2 = match l1,l2 with
| [],_ -> l2
| _,[] -> l1
- | (lid1, lid1_loc, lbl1,p1)::rem1, (lid2, lid2_loc, lbl2,p2)::rem2 ->
+ | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
- (lid1, lid1_loc, lbl1,p1)::lub_rec rem1 l2
+ (lid1, lbl1,p1)::lub_rec rem1 l2
else if lbl2.lbl_pos < lbl1.lbl_pos then
- (lid2, lid2_loc, lbl2,p2)::lub_rec l1 rem2
+ (lid2, lbl2,p2)::lub_rec l1 rem2
else
- (lid1, lid1_loc, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+ (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
lub_rec l1 l2
and lubs ps qs = match ps,qs with
| _ -> []
let name_counter = ref 0
- let fresh () =
+ let fresh name =
let current = !name_counter in
name_counter := !name_counter + 1;
- "#$%^@*@" ^ string_of_int current
+ "#$" ^ name ^ string_of_int current
let conv (typed: Typedtree.pattern) :
Parsetree.pattern list *
- (string,Path.t * Types.constructor_description) Hashtbl.t *
- (string,Path.t * Types.label_description) Hashtbl.t
+ (string, Types.constructor_description) Hashtbl.t *
+ (string, Types.label_description) Hashtbl.t
=
let constrs = Hashtbl.create 0 in
let labels = Hashtbl.create 0 in
List.map
(fun lst -> mkpat (Ppat_tuple lst))
results
- | Tpat_construct (cstr_path, cstr_lid, cstr,lst,_) ->
- let id = fresh () in
+ | Tpat_construct (cstr_lid, cstr,lst,_) ->
+ let id = fresh cstr.cstr_name in
let lid = { cstr_lid with txt = Longident.Lident id } in
- Hashtbl.add constrs id (cstr_path,cstr);
+ Hashtbl.add constrs id cstr;
let results = select (List.map loop lst) in
begin match lst with
[] ->
| Tpat_record (subpatterns, _closed_flag) ->
let pats =
select
- (List.map (fun (_,_,_,x) -> (loop x)) subpatterns)
+ (List.map (fun (_,_,x) -> loop x) subpatterns)
in
let label_idents =
List.map
- (fun (lbl_path,_,lbl,_) ->
- let id = fresh () in
- Hashtbl.add labels id (lbl_path, lbl);
+ (fun (_,lbl,_) ->
+ let id = fresh lbl.lbl_name in
+ Hashtbl.add labels id lbl;
Longident.Lident id)
subpatterns
in
Path.same path Predef.path_option)
let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) ->
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) ->
let path = get_type_path p.pat_type p.pat_env in
List.fold_left
collect_paths_from_pat
ps
| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
| Tpat_tuple ps | Tpat_array ps
-| Tpat_construct (_, _, {cstr_tag=Cstr_exception _}, ps,_)->
+| Tpat_construct (_, {cstr_tag=Cstr_exception _}, ps,_)->
List.fold_left collect_paths_from_pat r ps
| Tpat_record (lps,_) ->
List.fold_left
- (fun r (_, _, _, p) -> collect_paths_from_pat r p)
+ (fun r (_, _, p) -> collect_paths_from_pat r p)
r lps
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
| Tpat_or (p1,p2,_) ->
false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
true
-| Tpat_tuple ps | Tpat_construct (_, _, _, ps,_) | Tpat_array ps ->
+| Tpat_tuple ps | Tpat_construct (_, _, ps,_) | Tpat_array ps ->
List.for_all (fun p -> inactive p.pat_desc) ps
| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
inactive p.pat_desc
| Tpat_record (ldps,_) ->
- List.exists (fun (_, _, _, p) -> inactive p.pat_desc) ldps
+ List.exists (fun (_, _, p) -> inactive p.pat_desc) ldps
| Tpat_or (p,q,_) ->
inactive p.pat_desc && inactive q.pat_desc
| Partial -> Partial
| Total ->
(* checks for missing GADT constructors *)
+ (* let casel =
+ match casel with [] -> [] | a :: l -> a :: l @ [a] in *)
check_partial_param (do_check_partial_gadt pred)
do_check_fragile_gadt loc casel
(* *)
(***********************************************************************)
-(* $Id: parmatch.mli 12961 2012-09-27 13:30:07Z garrigue $ *)
-
(* Detection of partial matches and unused match cases. *)
open Asttypes
open Typedtree
open Types
+val pretty_const : constant -> string
val top_pretty : Format.formatter -> pattern -> unit
val pretty_pat : pattern -> unit
val pretty_line : pattern list -> unit
val omega_list : 'a list -> pattern list
val normalize_pat : pattern -> pattern
val all_record_args :
- (Path.t * Longident.t loc * label_description * pattern) list ->
- (Path.t * Longident.t loc * label_description * pattern) list
+ (Longident.t loc * label_description * pattern) list ->
+ (Longident.t loc * label_description * pattern) list
val const_compare : constant -> constant -> int
val le_pat : pattern -> pattern -> bool
val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
-(* Those to functions recombine one pattern and its arguments:
+(* Those two functions recombine one pattern and its arguments:
For instance:
(_,_)::p1::p2::rem -> (p1, p2)::rem
The second one will replace mutable arguments by '_'
val pressure_variants: Env.t -> pattern list -> unit
val check_partial: Location.t -> (pattern * expression) list -> partial
val check_partial_gadt:
- ((string,Path.t * constructor_description) Hashtbl.t ->
- (string,Path.t * label_description) Hashtbl.t ->
+ ((string, constructor_description) Hashtbl.t ->
+ (string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit
(* *)
(***********************************************************************)
-(* $Id: path.ml 12035 2012-01-18 09:15:27Z frisch $ *)
-
type t =
Pident of Ident.t
| Pdot of t * string * int
(* *)
(***********************************************************************)
-(* $Id: path.mli 12035 2012-01-18 09:15:27Z frisch $ *)
-
(* Access paths *)
type t =
(* *)
(***********************************************************************)
-(* $Id: predef.ml 12520 2012-05-31 07:41:37Z garrigue $ *)
-
(* Predefined type constructors (with special typing rules in typecore) *)
-open Asttypes
open Path
open Types
open Btype
and path_assert_failure = Pident ident_assert_failure
and path_undefined_recursive_module = Pident ident_undefined_recursive_module
+let decl_abstr =
+ {type_params = [];
+ type_arity = 0;
+ type_kind = Type_abstract;
+ type_loc = Location.none;
+ type_private = Asttypes.Public;
+ type_manifest = None;
+ type_variance = [];
+ type_newtype_level = None}
+
let ident_false = ident_create "false"
and ident_true = ident_create "true"
and ident_void = ident_create "()"
and ident_none = ident_create "None"
and ident_some = ident_create "Some"
let build_initial_env add_type add_exception empty_env =
- let decl_abstr =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_abstract;
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [];
- type_newtype_level = None}
- and decl_bool =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_variant([ident_false, [], None; ident_true, [], None]);
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [];
- type_newtype_level = None}
+ let decl_bool =
+ {decl_abstr with
+ type_kind = Type_variant([ident_false, [], None; ident_true, [], None])}
and decl_unit =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_variant([ident_void, [], None]);
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [];
- type_newtype_level = None}
+ {decl_abstr with
+ type_kind = Type_variant([ident_void, [], None])}
and decl_exn =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_variant [];
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [];
- type_newtype_level = None}
+ {decl_abstr with
+ type_kind = Type_variant []}
and decl_array =
let tvar = newgenvar() in
- {type_params = [tvar];
+ {decl_abstr with
+ type_params = [tvar];
type_arity = 1;
- type_kind = Type_abstract;
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [true, true, true];
- type_newtype_level = None}
+ type_variance = [Variance.full]}
and decl_list =
let tvar = newgenvar() in
- {type_params = [tvar];
+ {decl_abstr with
+ type_params = [tvar];
type_arity = 1;
type_kind =
Type_variant([ident_nil, [], None; ident_cons, [tvar; type_list tvar],
None]);
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [true, false, false];
- type_newtype_level = None}
+ type_variance = [Variance.covariant]}
and decl_format6 =
- {type_params = [
- newgenvar(); newgenvar(); newgenvar();
- newgenvar(); newgenvar(); newgenvar();
- ];
+ let params = List.map newgenvar [();();();();();()] in
+ {decl_abstr with
+ type_params = params;
type_arity = 6;
- type_kind = Type_abstract;
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [
- true, true, true; true, true, true;
- true, true, true; true, true, true;
- true, true, true; true, true, true;
- ];
- type_newtype_level = None}
+ type_variance = List.map (fun _ -> Variance.full) params}
and decl_option =
let tvar = newgenvar() in
- {type_params = [tvar];
+ {decl_abstr with
+ type_params = [tvar];
type_arity = 1;
type_kind = Type_variant([ident_none, [], None; ident_some, [tvar], None]);
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [true, false, false];
- type_newtype_level = None}
+ type_variance = [Variance.covariant]}
and decl_lazy_t =
let tvar = newgenvar() in
- {type_params = [tvar];
+ {decl_abstr with
+ type_params = [tvar];
type_arity = 1;
- type_kind = Type_abstract;
- type_loc = Location.none;
- type_private = Public;
- type_manifest = None;
- type_variance = [true, false, false];
- type_newtype_level = None}
+ type_variance = [Variance.covariant]}
in
let add_exception id l =
(* *)
(***********************************************************************)
-(* $Id: predef.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Predefined type constructors (with special typing rules in typecore) *)
open Types
(* *)
(***********************************************************************)
-(* $Id: primitive.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Description of primitive functions *)
open Misc
(* *)
(***********************************************************************)
-(* $Id: primitive.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Description of primitive functions *)
type description =
(* *)
(***********************************************************************)
-(* $Id: printtyp.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Printing functions *)
open Misc
(* Print a long identifier *)
let rec longident ppf = function
- | Lident s -> fprintf ppf "%s" s
+ | Lident s -> pp_print_string ppf s
| Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
| Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
with Not_found ->
unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names
-let ident ppf id = fprintf ppf "%s" (ident_name id)
+let ident ppf id = pp_print_string ppf (ident_name id)
(* Print a path *)
| Pident id ->
ident ppf id
| Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
- fprintf ppf "%s" s
+ pp_print_string ppf s
| Pdot(p, s, pos) ->
- fprintf ppf "%a.%s" path p s
+ path ppf p;
+ pp_print_char ppf '.';
+ pp_print_string ppf s
| Papply(p1, p2) ->
fprintf ppf "%a(%a)" path p1 path p2
+let rec string_of_out_ident = function
+ | Oide_ident s -> s
+ | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
+ | Oide_apply (id1, id2) ->
+ String.concat ""
+ [string_of_out_ident id1; "("; string_of_out_ident id2; ")"]
+
+let string_of_path p = string_of_out_ident (tree_of_path p)
+
(* Print a recursive annotation *)
let tree_of_rec = function
let () = Btype.print_raw := raw_type_expr
+(* Normalize paths *)
+
+type param_subst = Id | Nth of int | Map of int list
+
+let compose l1 = function
+ | Id -> Map l1
+ | Map l2 -> Map (List.map (List.nth l1) l2)
+ | Nth n -> Nth (List.nth l1 n)
+
+let apply_subst s1 tyl =
+ match s1 with
+ Nth n1 -> [List.nth tyl n1]
+ | Map l1 -> List.map (List.nth tyl) l1
+ | Id -> tyl
+
+type best_path = Paths of Path.t list | Best of Path.t
+
+let printing_env = ref Env.empty
+let printing_old = ref Env.empty
+let printing_pers = ref Concr.empty
+module Path2 = struct
+ include Path
+ let rec compare p1 p2 =
+ (* must ignore position when comparing paths *)
+ match (p1, p2) with
+ (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) ->
+ let c = compare p1 p2 in
+ if c <> 0 then c else String.compare s1 s2
+ | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+ let c = compare fun1 fun2 in
+ if c <> 0 then c else compare arg1 arg2
+ | _ -> Pervasives.compare p1 p2
+end
+module PathMap = Map.Make(Path2)
+let printing_map = ref (Lazy.lazy_from_val PathMap.empty)
+
+let same_type t t' = repr t == repr t'
+
+let rec index l x =
+ match l with
+ [] -> raise Not_found
+ | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+ [] -> true
+ | a :: l -> not (List.memq a l) && uniq l
+
+let rec normalize_type_path ?(cache=false) env p =
+ try
+ let desc = Env.find_type p env in
+ if desc.type_private = Private || desc.type_newtype_level <> None then
+ (p, Id)
+ else match desc.type_manifest with
+ Some ty ->
+ let params = List.map repr desc.type_params in
+ begin match repr ty with
+ {desc = Tconstr (p1, tyl, _)} ->
+ let tyl = List.map repr tyl in
+ if List.length params = List.length tyl
+ && List.for_all2 (==) params tyl
+ then normalize_type_path ~cache env p1
+ else if cache || List.length params <= List.length tyl
+ || not (uniq tyl) then (p, Id)
+ else
+ let l1 = List.map (index params) tyl in
+ let (p2, s2) = normalize_type_path ~cache env p1 in
+ (p2, compose l1 s2)
+ | ty ->
+ (p, Nth (index params ty))
+ end
+ | None -> (p, Id)
+ with
+ Not_found -> (p, Id)
+
+let rec path_size = function
+ Pident id ->
+ (let s = Ident.name id in if s <> "" && s.[0] = '_' then 10 else 1),
+ -Ident.binding_time id
+ | Pdot (p, _, _) ->
+ let (l, b) = path_size p in (1+l, b)
+ | Papply (p1, p2) ->
+ let (l, b) = path_size p1 in
+ (l + fst (path_size p2), b)
+
+let same_printing_env env =
+ let used_pers = Env.used_persistent () in
+ Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
+
+let set_printing_env env =
+ printing_env := if !Clflags.real_paths then Env.empty else env;
+ if !printing_env == Env.empty || same_printing_env env then () else
+ begin
+ (* printf "Reset printing_map@."; *)
+ printing_old := env;
+ printing_pers := Env.used_persistent ();
+ printing_map := lazy begin
+ (* printf "Recompute printing_map.@."; *)
+ let map = ref PathMap.empty in
+ Env.iter_types
+ (fun p (p', decl) ->
+ let (p1, s1) = normalize_type_path env p' ~cache:true in
+ (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
+ if s1 = Id then
+ try
+ let r = PathMap.find p1 !map in
+ match !r with
+ Paths l -> r := Paths (p :: l)
+ | Best _ -> assert false
+ with Not_found ->
+ map := PathMap.add p1 (ref (Paths [p])) !map)
+ env;
+ !map
+ end
+ end
+
+let wrap_printing_env env f =
+ set_printing_env env;
+ try_finally f (fun () -> set_printing_env Env.empty)
+
+let is_unambiguous path env =
+ let l = Env.find_shadowed_types path env in
+ List.exists (Path.same path) l || (* concrete paths are ok *)
+ match l with
+ [] -> true
+ | p :: rem ->
+ (* allow also coherent paths: *)
+ let normalize p = fst (normalize_type_path ~cache:true env p) in
+ let p' = normalize p in
+ List.for_all (fun p -> Path.same (normalize p) p') rem ||
+ (* also allow repeatedly defining and opening (for toplevel) *)
+ let id = lid_of_path p in
+ List.for_all (fun p -> lid_of_path p = id) rem &&
+ Path.same p (fst (Env.lookup_type id env))
+
+let rec get_best_path r =
+ match !r with
+ Best p' -> p'
+ | Paths [] -> raise Not_found
+ | Paths l ->
+ r := Paths [];
+ List.iter
+ (fun p ->
+ (* Format.eprintf "evaluating %a@." path p; *)
+ match !r with
+ Best p' when path_size p >= path_size p' -> ()
+ | _ -> if is_unambiguous p !printing_env then r := Best p)
+ (* else Format.eprintf "%a ignored as ambiguous@." path p *)
+ l;
+ get_best_path r
+
+let best_type_path p =
+ if !Clflags.real_paths || !printing_env == Env.empty
+ then (p, Id)
+ else
+ let (p', s) = normalize_type_path !printing_env p in
+ let p'' =
+ try get_best_path (PathMap.find p' (Lazy.force !printing_map))
+ with Not_found -> p'
+ in
+ (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
+ (p'', s)
+
(* Print a type expression *)
let names = ref ([] : (type_expr * string) list)
end
let aliasable ty =
- match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
+ match ty.desc with
+ Tvar _ | Tunivar _ | Tpoly _ -> false
+ | Tconstr (p, _, _) ->
+ (match best_type_path p with (_, Nth _) -> false | _ -> true)
+ | _ -> true
let namable_row row =
row.row_name <> None &&
| Tarrow(_, ty1, ty2, _) ->
mark_loops_rec visited ty1; mark_loops_rec visited ty2
| Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
- | Tconstr(_, tyl, _) | Tpackage (_, _, tyl) ->
+ | Tconstr(p, tyl, _) ->
+ let (p', s) = best_type_path p in
+ List.iter (mark_loops_rec visited) (apply_subst s tyl)
+ | Tpackage (_, _, tyl) ->
List.iter (mark_loops_rec visited) tyl
| Tvariant row ->
if List.memq px !visited_objects then add_alias px else
| Ttuple tyl ->
Otyp_tuple (tree_of_typlist sch tyl)
| Tconstr(p, tyl, abbrev) ->
- Otyp_constr (tree_of_path p, tree_of_typlist sch tyl)
+ begin match best_type_path p with
+ (_, Nth n) -> tree_of_typexp sch (List.nth tyl n)
+ | (p', s) ->
+ let tyl' = apply_subst s tyl in
+ Otyp_constr (tree_of_path p', tree_of_typlist sch tyl')
+ end
| Tvariant row ->
let row = row_repr row in
let fields =
let all_present = List.length present = List.length fields in
begin match row.row_name with
| Some(p, tyl) when namable_row row ->
- let id = tree_of_path p in
+ let (p', s) = best_type_path p in
+ assert (s = Id);
+ let id = tree_of_path p' in
let args = tree_of_typlist sch tyl in
if row.row_closed && all_present then
Otyp_constr (id, args)
let non_gen = is_non_gen sch px in
let tags =
if all_present then None else Some (List.map fst present) in
- Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
+ Otyp_variant (non_gen, Ovar_name(id, args),
row.row_closed, tags)
| _ ->
let non_gen =
| Some (p, ty :: tyl) ->
let non_gen = is_non_gen sch (repr ty) in
let args = tree_of_typlist sch tyl in
- Otyp_class (non_gen, tree_of_path p, args)
+ let (p', s) = best_type_path p in
+ assert (s = Id);
+ Otyp_class (non_gen, tree_of_path p', args)
| _ ->
fatal_error "Printtyp.tree_of_typobject"
end
let params = filter_params decl.type_params in
+ begin match decl.type_manifest with
+ | Some ty ->
+ let vars = free_variables ty in
+ List.iter
+ (function {desc = Tvar (Some "_")} as ty ->
+ if List.memq ty vars then ty.desc <- Tvar None
+ | _ -> ())
+ params
+ | None -> ()
+ end;
+
List.iter add_alias params;
List.iter mark_loops params;
List.iter check_name_of_type (List.map proxy params);
in
let vari =
List.map2
- (fun ty (co,cn,ct) ->
- if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
+ (fun ty v ->
+ if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v
+ else (true,true))
decl.type_params decl.type_variance
in
(Ident.name id,
let tyl = tree_of_typlist true params in
List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
+let class_variance =
+ List.map Variance.(fun v -> mem May_pos v, mem May_neg v)
+
let tree_of_class_declaration id cl rs =
let params = filter_params cl.cty_params in
let vir_flag = cl.cty_new = None in
Osig_class
(vir_flag, Ident.name id,
- List.map2 tree_of_class_param params cl.cty_variance,
+ List.map2 tree_of_class_param params (class_variance cl.cty_variance),
tree_of_class_type true params cl.cty_type,
tree_of_rec rs)
Osig_class_type
(virt, Ident.name id,
- List.map2 tree_of_class_param params cl.clty_variance,
+ List.map2 tree_of_class_param params (class_variance cl.clty_variance),
tree_of_class_type true params cl.clty_type,
tree_of_rec rs)
(* Print a module type *)
+let wrap_env fenv ftree arg =
+ let env = !printing_env in
+ set_printing_env (fenv env);
+ let tree = ftree arg in
+ set_printing_env env;
+ tree
+
+let filter_rem_sig item rem =
+ match item, rem with
+ | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem ->
+ ([ctydecl; tydecl1; tydecl2], rem)
+ | Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
+ ([tydecl1; tydecl2], rem)
+ | _ ->
+ ([], rem)
+
+let dummy =
+ { type_params = []; type_arity = 0; type_kind = Type_abstract;
+ type_private = Public; type_manifest = None; type_variance = [];
+ type_newtype_level = None; type_loc = Location.none; }
+
+let hide_rec_items = function
+ | Sig_type(id, decl, rs) ::rem
+ when rs <> Trec_next && not !Clflags.real_paths ->
+ let rec get_ids = function
+ Sig_type (id, _, Trec_next) :: rem ->
+ id :: get_ids rem
+ | _ -> []
+ in
+ let ids = id :: get_ids rem in
+ set_printing_env
+ (List.fold_right
+ (fun id -> Env.add_type (Ident.rename id) dummy)
+ ids !printing_env)
+ | _ -> ()
+
let rec tree_of_modtype = function
| Mty_ident p ->
Omty_ident (tree_of_path p)
Omty_signature (tree_of_signature sg)
| Mty_functor(param, ty_arg, ty_res) ->
Omty_functor
- (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res)
-
-and tree_of_signature = function
- | [] -> []
- | Sig_value(id, decl) :: rem ->
- tree_of_value_description id decl :: tree_of_signature rem
- | Sig_type(id, _, _) :: rem when is_row_name (Ident.name id) ->
- tree_of_signature rem
- | Sig_type(id, decl, rs) :: rem ->
- Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
- tree_of_signature rem
- | Sig_exception(id, decl) :: rem ->
- tree_of_exception_declaration id decl :: tree_of_signature rem
- | Sig_module(id, mty, rs) :: rem ->
- Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
- tree_of_signature rem
- | Sig_modtype(id, decl) :: rem ->
- tree_of_modtype_declaration id decl :: tree_of_signature rem
- | Sig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem ->
- tree_of_class_declaration id decl rs :: tree_of_signature rem
- | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
- tree_of_cltype_declaration id decl rs :: tree_of_signature rem
- | _ ->
- assert false
+ (Ident.name param, tree_of_modtype ty_arg,
+ wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res)
+
+and tree_of_signature sg =
+ wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg
+
+and tree_of_signature_rec env' = function
+ [] -> []
+ | item :: rem ->
+ begin match item with
+ Sig_type (_, _, rs) when rs <> Trec_next -> ()
+ | _ -> set_printing_env env'
+ end;
+ let (sg, rem) = filter_rem_sig item rem in
+ let trees =
+ match item with
+ | Sig_value(id, decl) ->
+ [tree_of_value_description id decl]
+ | Sig_type(id, _, _) when is_row_name (Ident.name id) ->
+ []
+ | Sig_type(id, decl, rs) ->
+ hide_rec_items (item :: rem);
+ [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)]
+ | Sig_exception(id, decl) ->
+ [tree_of_exception_declaration id decl]
+ | Sig_module(id, mty, rs) ->
+ [Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)]
+ | Sig_modtype(id, decl) ->
+ [tree_of_modtype_declaration id decl]
+ | Sig_class(id, decl, rs) ->
+ [tree_of_class_declaration id decl rs]
+ | Sig_class_type(id, decl, rs) ->
+ [tree_of_cltype_declaration id decl rs]
+ in
+ let env' = Env.add_signature (item :: sg) env' in
+ trees @ tree_of_signature_rec env' rem
and tree_of_modtype_declaration id decl =
let mty =
(* Print an unification error *)
+let same_path t t' =
+ let t = repr t and t' = repr t' in
+ t == t' ||
+ match t.desc, t'.desc with
+ Tconstr(p,tl,_), Tconstr(p',tl',_) ->
+ let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in
+ begin match s1, s2 with
+ Nth n1, Nth n2 when n1 = n2 -> true
+ | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
+ let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
+ List.length tl = List.length tl' &&
+ List.for_all2 same_type tl tl'
+ | _ -> false
+ end
+ | _ ->
+ false
+
let type_expansion t ppf t' =
- if t == t' then type_expr ppf t else
+ if same_path t t' then type_expr ppf t else
let t' = if proxy t == proxy t' then unalias t' else t' in
fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
+let type_path_expansion tp ppf tp' =
+ if Path.same tp tp' then path ppf tp else
+ fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'
+
let rec trace fst txt ppf = function
| (t1, t1') :: (t2, t2') :: rem ->
if not fst then fprintf ppf "@,";
(trace false txt) rem
| _ -> ()
-let rec filter_trace = function
+let rec filter_trace keep_last = function
| (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' ->
[]
| (t1, t1') :: (t2, t2') :: rem ->
- let rem' = filter_trace rem in
- if t1 == t1' && t2 == t2'
+ let rem' = filter_trace keep_last rem in
+ if is_constr_row t1' || is_constr_row t2'
+ || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])
then rem'
else (t1, t1') :: (t2, t2') :: rem'
| _ -> []
+let rec type_path_list ppf = function
+ | [tp, tp'] -> type_path_expansion tp ppf tp'
+ | (tp, tp') :: rem ->
+ fprintf ppf "%a@;<2 0>%a"
+ (type_path_expansion tp) tp'
+ type_path_list rem
+ | [] -> ()
+
(* Hide variant name and var, to force printing the expanded type *)
let hide_variant_name t =
match repr t with
let prepare_expansion (t, t') =
let t' = hide_variant_name t' in
- mark_loops t; if t != t' then mark_loops t';
+ mark_loops t;
+ if not (same_path t t') then mark_loops t';
(t, t')
let may_prepare_expansion compact (t, t') =
let has_explanation unif t3 t4 =
match t3.desc, t4.desc with
Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
+ | Tnil, Tconstr _ | Tconstr _, Tnil
| _, Tvar _ | Tvar _, _
| Tvariant _, Tvariant _ -> true
| Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
| Tfield (l, _, _, _), (Tnil|Tconstr _) ->
fprintf ppf
"@,@[The second object type has no method %s@]" l
+ | Tnil, Tconstr _ | Tconstr _, Tnil ->
+ fprintf ppf
+ "@,@[The %s object type has an abstract row, it cannot be closed@]"
+ (if t4.desc = Tnil then "first" else "second")
| Tvariant row1, Tvariant row2 ->
let row1 = row_repr row1 and row2 = row_repr row2 in
begin match
let type_same_name t1 t2 =
match (repr t1).desc, (repr t2).desc with
- Tconstr (p1, _, _), Tconstr (p2, _, _) -> path_same_name p1 p2
+ Tconstr (p1, _, _), Tconstr (p2, _, _) ->
+ path_same_name (fst (best_type_path p1)) (fst (best_type_path p2))
| _ -> ()
let rec trace_same_names = function
| [] | _ :: [] -> assert false
| t1 :: t2 :: tr ->
try
- let tr = filter_trace tr in
+ let tr = filter_trace (mis = None) tr in
let t1, t1' = may_prepare_expansion (tr = []) t1
and t2, t2' = may_prepare_expansion (tr = []) t2 in
print_labels := not !Clflags.classic;
print_labels := true;
raise exn
-let report_unification_error ppf tr txt1 txt2 =
- unification_error true tr txt1 ppf txt2;;
+let report_unification_error ppf env ?(unif=true)
+ tr txt1 txt2 =
+ wrap_printing_env env (fun () -> unification_error unif tr txt1 ppf txt2)
+;;
-let trace fst txt ppf tr =
+let trace fst keep_last txt ppf tr =
print_labels := not !Clflags.classic;
trace_same_names tr;
try match tr with
t1 :: t2 :: tr' ->
- if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr')
- else trace fst txt ppf (filter_trace tr);
+ if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
+ else trace fst txt ppf (filter_trace keep_last tr);
print_labels := true
| _ -> ()
with exn ->
print_labels := true;
raise exn
-let report_subtyping_error ppf tr1 txt1 tr2 =
- reset ();
- let tr1 = List.map prepare_expansion tr1
- and tr2 = List.map prepare_expansion tr2 in
- trace true txt1 ppf tr1;
- if tr2 = [] then () else
- let mis = mismatch true tr2 in
- trace false "is not compatible with type" ppf tr2;
- explanation true mis ppf
+let report_subtyping_error ppf env tr1 txt1 tr2 =
+ wrap_printing_env env (fun () ->
+ reset ();
+ let tr1 = List.map prepare_expansion tr1
+ and tr2 = List.map prepare_expansion tr2 in
+ fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
+ if tr2 = [] then fprintf ppf "@]" else
+ let mis = mismatch true tr2 in
+ fprintf ppf "%a%t@]"
+ (trace false (mis = None) "is not compatible with type") tr2
+ (explanation true mis))
+
+let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
+ wrap_printing_env env (fun () ->
+ reset ();
+ List.iter
+ (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
+ tpl;
+ match tpl with
+ [] -> assert false
+ | [tp, tp'] ->
+ fprintf ppf
+ "@[%t@;<1 2>%a@ \
+ %t@;<1 2>%a\
+ @]"
+ txt1 (type_path_expansion tp) tp'
+ txt3 (type_path_expansion tp0) tp0'
+ | _ ->
+ fprintf ppf
+ "@[%t@;<1 2>@[<hv>%a@]\
+ @ %t@;<1 2>%a\
+ @]"
+ txt2 type_path_list tpl
+ txt3 (type_path_expansion tp0) tp0')
(* *)
(***********************************************************************)
-(* $Id: printtyp.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
(* Printing functions *)
open Format
val ident: formatter -> Ident.t -> unit
val tree_of_path: Path.t -> out_ident
val path: formatter -> Path.t -> unit
+val string_of_path: Path.t -> string
val raw_type_expr: formatter -> type_expr -> unit
+
+val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a
+ (* Call the function using the environment for type path shortening *)
+ (* This affects all the printing functions below *)
+
val reset: unit -> unit
val mark_loops: type_expr -> unit
val reset_and_mark_loops: type_expr -> unit
val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
-val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit
-val unification_error:
- bool -> (type_expr * type_expr) list ->
- (formatter -> unit) -> formatter -> (formatter -> unit) ->
- unit
+val trace:
+ bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit
val report_unification_error:
- formatter -> (type_expr * type_expr) list ->
+ formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
(formatter -> unit) -> (formatter -> unit) ->
unit
val report_subtyping_error:
- formatter -> (type_expr * type_expr) list ->
+ formatter -> Env.t -> (type_expr * type_expr) list ->
string -> (type_expr * type_expr) list -> unit
+val report_ambiguous_type_error:
+ formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+ (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+(* for toploop *)
+val hide_rec_items: signature_item list -> unit
(* *)
(***********************************************************************)
-(* $Id: printast.ml 12414 2012-05-02 14:36:55Z lefessan $ *)
-
open Asttypes;;
open Format;;
open Lexing;;
| Tpat_tuple (l) ->
line i ppf "Ppat_tuple\n";
list i pattern ppf l;
- | Tpat_construct (li, _, _, po, explicity_arity) ->
- line i ppf "Ppat_construct %a\n" fmt_path li;
+ | Tpat_construct (li, _, po, explicity_arity) ->
+ line i ppf "Ppat_construct %a\n" fmt_longident li;
list i pattern ppf po;
bool i ppf explicity_arity;
| Tpat_variant (l, po, _) ->
line i ppf "Pexp_constraint\n";
option i core_type ppf cto1;
option i core_type ppf cto2;
- | Texp_open (m, _, _) ->
- line i ppf "Pexp_open \"%a\"\n" fmt_path m;
+ | Texp_open (ovf, m, _, _) ->
+ line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
| Texp_poly cto ->
line i ppf "Pexp_poly\n";
option i core_type ppf cto;
| Texp_tuple (l) ->
line i ppf "Pexp_tuple\n";
list i expression ppf l;
- | Texp_construct (li, _, _, eo, b) ->
- line i ppf "Pexp_construct %a\n" fmt_path li;
+ | Texp_construct (li, _, eo, b) ->
+ line i ppf "Pexp_construct %a\n" fmt_longident li;
list i expression ppf eo;
bool i ppf b;
| Texp_variant (l, eo) ->
line i ppf "Pexp_record\n";
list i longident_x_expression ppf l;
option i expression ppf eo;
- | Texp_field (e, li, _, _) ->
+ | Texp_field (e, li, _) ->
line i ppf "Pexp_field\n";
expression i ppf e;
- path i ppf li;
- | Texp_setfield (e1, li, _, _, e2) ->
+ longident i ppf li;
+ | Texp_setfield (e1, li, _, e2) ->
line i ppf "Pexp_setfield\n";
expression i ppf e1;
- path i ppf li;
+ longident i ppf li;
expression i ppf e2;
| Texp_array (l) ->
line i ppf "Pexp_array\n";
| Tsig_modtype (s, _, md) ->
line i ppf "Psig_modtype \"%a\"\n" fmt_ident s;
modtype_declaration i ppf md;
- | Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li;
+ | Tsig_open (ovf, li,_) ->
+ line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li;
| Tsig_include (mt, _) ->
line i ppf "Psig_include\n";
module_type i ppf mt;
| Tstr_modtype (s, _, mt) ->
line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s;
module_type i ppf mt;
- | Tstr_open (li, _) -> line i ppf "Pstr_open %a\n" fmt_path li;
+ | Tstr_open (ovf, li, _) ->
+ line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li;
| Tstr_class (l) ->
line i ppf "Pstr_class\n";
list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l);
line i ppf "<params> %a\n" fmt_location loc;
list (i+1) string_loc ppf l;
-and longident_x_pattern i ppf (li, _, _, p) =
- line i ppf "%a\n" fmt_path li;
+and longident_x_pattern i ppf (li, _, p) =
+ line i ppf "%a\n" fmt_longident li;
pattern (i+1) ppf p;
and pattern_x_expression_case i ppf (p, e) =
line i ppf "<override> \"%a\"\n" fmt_path s;
expression (i+1) ppf e;
-and longident_x_expression i ppf (li, _, _, e) =
- line i ppf "%a\n" fmt_path li;
+and longident_x_expression i ppf (li, _, e) =
+ line i ppf "%a\n" fmt_longident li;
expression (i+1) ppf e;
and label_x_expression i ppf (l, e, _) =
let interface ppf x = list 0 signature_item ppf x.sig_items;;
let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf (x, _) = implementation ppf x
(* *)
(***********************************************************************)
-(* $Id: printast.mli 12404 2012-04-26 13:20:09Z lefessan $ *)
-
open Typedtree;;
open Format;;
val interface : formatter -> signature -> unit;;
val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+ formatter -> (structure * module_coercion) -> unit;;
(* *)
(***********************************************************************)
-(* $Id: stypes.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Recording and dumping (partial) type information *)
(*
*)
open Annot;;
-open Format;;
open Lexing;;
open Location;;
open Typedtree;;
+let output_int oc i = output_string oc (string_of_int i)
+
type annotation =
| Ti_pat of pattern
| Ti_expr of expression
let print_position pp pos =
if pos = dummy_pos then
- fprintf pp "--"
- else
- fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol
- pos.pos_cnum;
+ output_string pp "--"
+ else begin
+ output_char pp '\"';
+ output_string pp (String.escaped pos.pos_fname);
+ output_string pp "\" ";
+ output_int pp pos.pos_lnum;
+ output_char pp ' ';
+ output_int pp pos.pos_bol;
+ output_char pp ' ';
+ output_int pp pos.pos_cnum;
+ end
;;
let print_location pp loc =
print_position pp loc.loc_start;
- fprintf pp " ";
+ output_char pp ' ';
print_position pp loc.loc_end;
;;
let print_ident_annot pp str k =
match k with
- | Idef l -> fprintf pp "def %s %a@." str print_location l;
- | Iref_internal l -> fprintf pp "int_ref %s %a@." str print_location l;
- | Iref_external -> fprintf pp "ext_ref %s@." str;
+ | Idef l ->
+ output_string pp "def ";
+ output_string pp str;
+ output_char pp ' ';
+ print_location pp l;
+ output_char pp '\n'
+ | Iref_internal l ->
+ output_string pp "int_ref ";
+ output_string pp str;
+ output_char pp ' ';
+ print_location pp l;
+ output_char pp '\n'
+ | Iref_external ->
+ output_string pp "ext_ref ";
+ output_string pp str;
+ output_char pp '\n'
;;
(* The format of the annotation file is documented in emacs/caml-types.el. *)
let print_info pp prev_loc ti =
match ti with
| Ti_class _ | Ti_mod _ -> prev_loc
- | Ti_pat {pat_loc = loc; pat_type = typ}
- | Ti_expr {exp_loc = loc; exp_type = typ} ->
- if loc <> prev_loc then fprintf pp "%a@." print_location loc;
- fprintf pp "type(@. ";
+ | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env}
+ | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} ->
+ if loc <> prev_loc then begin
+ print_location pp loc;
+ output_char pp '\n'
+ end;
+ output_string pp "type(\n";
printtyp_reset_maybe loc;
Printtyp.mark_loops typ;
- Printtyp.type_sch pp typ;
- fprintf pp "@.)@.";
+ Format.pp_print_string Format.str_formatter " ";
+ Printtyp.wrap_printing_env env
+ (fun () -> Printtyp.type_sch Format.str_formatter typ);
+ Format.pp_print_newline Format.str_formatter ();
+ let s = Format.flush_str_formatter () in
+ output_string pp s;
+ output_string pp ")\n";
loc
| An_call (loc, k) ->
- if loc <> prev_loc then fprintf pp "%a@." print_location loc;
- fprintf pp "call(@. %s@.)@." (call_kind_string k);
+ if loc <> prev_loc then begin
+ print_location pp loc;
+ output_char pp '\n'
+ end;
+ output_string pp "call(\n ";
+ output_string pp (call_kind_string k);
+ output_string pp "\n)\n";
loc
| An_ident (loc, str, k) ->
- if loc <> prev_loc then fprintf pp "%a@." print_location loc;
- fprintf pp "ident(@. ";
+ if loc <> prev_loc then begin
+ print_location pp loc;
+ output_char pp '\n'
+ end;
+ output_string pp "ident(\n ";
print_ident_annot pp str k;
- fprintf pp ")@.";
+ output_string pp ")\n";
loc
;;
let info = get_info () in
let pp =
match filename with
- None -> std_formatter
- | Some filename -> formatter_of_out_channel (open_out filename) in
+ None -> stdout
+ | Some filename -> open_out filename in
sort_filter_phrases ();
ignore (List.fold_left (print_info pp) Location.none info);
phrases := [];
(* *)
(***********************************************************************)
-(* $Id: stypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Recording and dumping (partial) type information *)
(* Clflags.save_types must be true *)
(* *)
(***********************************************************************)
-(* $Id: subst.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Substitutions *)
open Misc
| Papply(p1, p2) ->
Papply(module_path s p1, module_path s p2)
-let rec modtype_path s = function
+let modtype_path s = function
Pident id as p ->
begin try
match Tbl.find id s.modtypes with
(* *)
(***********************************************************************)
-(* $Id: subst.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Substitutions *)
open Types
(* *)
(***********************************************************************)
-(* $Id: typeclass.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
-open Misc
open Parsetree
open Asttypes
open Path
| Final_self_clash of (type_expr * type_expr) list
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
+ | Duplicate of string * string
+
+exception Error of Location.t * Env.t * error
open Typedtree
let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc }
-exception Error of Location.t * error
-
(**********************)
(* Useful constants *)
| cty -> cty
(* Generalize a class type *)
-let rec generalize_class_type =
+let rec generalize_class_type gen =
function
Cty_constr (_, params, cty) ->
- List.iter Ctype.generalize params;
- generalize_class_type cty
+ List.iter gen params;
+ generalize_class_type gen cty
| Cty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
- Ctype.generalize sty;
- Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
- List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
+ gen sty;
+ Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+ List.iter (fun (_,tl) -> List.iter gen tl) inher
| Cty_fun (_, ty, cty) ->
- Ctype.generalize ty;
- generalize_class_type cty
+ gen ty;
+ generalize_class_type gen cty
+
+let generalize_class_type vars =
+ let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+ generalize_class_type gen
(* Return the virtual methods of a class type *)
let virtual_methods sign =
| Cty_fun (_, ty, cty) ->
class_body cty
-let rec extract_constraints cty =
+let extract_constraints cty =
let sign = Ctype.signature_of_class_type cty in
(Vars.fold (fun lab _ vars -> lab :: vars) sign.cty_vars [],
begin let (fields, _) =
let (id, virt) =
try
let (id, mut', virt', ty') = Vars.find lab !vars in
- if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
+ if mut' <> mut then
+ raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
Ctype.unify val_env (instance ty) (instance ty');
(if not inh then Some id else None),
(if virt' = Concrete then virt' else virt)
with
Ctype.Unify tr ->
- raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
+ raise (Error(loc, val_env,
+ Field_type_mismatch("instance variable", lab, tr)))
| Not_found -> None, virt
in
let (id, _, _, _) as result =
with Ctype.Unify trace ->
match trace with
_::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
- raise(Error(loc, Field_type_mismatch ("method", n, rem)))
+ raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
| _ ->
assert false
end;
(cname :: Concr.elements over_vals));
| Some Override
when Concr.is_empty over_meths && Concr.is_empty over_vals ->
- raise (Error(loc, No_overriding ("","")))
+ raise (Error(loc, env, No_overriding ("","")))
| _ -> ()
end;
(cl_sig, concr_meths, warn_vals)
| _ ->
- raise(Error(loc, Structure_expected parent))
+ raise(Error(loc, env, Structure_expected parent))
let virtual_method val_env meths self_type lab priv sty loc =
let (_, ty') =
let ty = cty.ctyp_type in
begin
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Field_type_mismatch ("method", lab, trace)));
+ raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
end;
cty
in
let unif ty =
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+ raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
in
match sty.ptyp_desc, priv with
Ptyp_poly ([],sty'), Public ->
let ty' = cty'.ctyp_type in
begin
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Unconsistent_constraint trace));
+ raise(Error(loc, val_env, Unconsistent_constraint trace));
end;
(cty, cty')
begin try
Ctype.unify env self_type dummy_obj
with Ctype.Unify _ ->
- raise(Error(sty.ptyp_loc, Pattern_type_clash self_type))
+ raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
end;
(* Class type fields *)
Pcty_constr (lid, styl) ->
let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
if Path.same decl.clty_path unbound_class then
- raise(Error(scty.pcty_loc, Unbound_class_type_2 lid.txt));
+ raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
let (params, clty) =
Ctype.instance_class decl.clty_params decl.clty_type
in
if List.length params <> List.length styl then
- raise(Error(scty.pcty_loc,
+ raise(Error(scty.pcty_loc, env,
Parameter_arity_mismatch (lid.txt, List.length params,
List.length styl)));
let ctys = List.map2
let ty' = cty'.ctyp_type in
begin
try Ctype.unify env ty' ty with Ctype.Unify trace ->
- raise(Error(sty.ptyp_loc, Parameter_mismatch trace))
+ raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
end;
cty'
) styl params
(*******************************)
let rec class_field self_loc cl_num self_type meths vars
- (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher)
+ (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher,
+ local_meths, local_vals)
cf =
let loc = cf.pcf_loc in
match cf.pcf_desc with
(val_env, met_env, par_env,
lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc)
:: fields,
- concr_meths, warn_vals, inher)
+ concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_valvirt (lab, mut, styp) ->
if !Clflags.principal then Ctype.begin_def ();
lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty,
met_env' == met_env)) loc)
:: fields,
- concr_meths, warn_vals, inher)
+ concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_val (lab, mut, ovf, sexp) ->
+ if Concr.mem lab.txt local_vals then
+ raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
if Concr.mem lab.txt warn_vals then begin
if ovf = Fresh then
Location.prerr_warning lab.loc
(Warnings.Instance_variable_override[lab.txt])
end else begin
if ovf = Override then
- raise(Error(loc, No_overriding ("instance variable", lab.txt)))
+ raise(Error(loc, val_env,
+ No_overriding ("instance variable", lab.txt)))
end;
if !Clflags.principal then Ctype.begin_def ();
let exp =
try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
- raise(Error(loc, Make_nongen_seltype ty))
+ raise(Error(loc, val_env, Make_nongen_seltype ty))
in
if !Clflags.principal then begin
Ctype.end_def ();
lazy (mkcf (Tcf_val (lab.txt, lab, mut, id,
Tcfk_concrete exp, met_env' == met_env)) loc)
:: fields,
- concr_meths, Concr.add lab.txt warn_vals, inher)
+ concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+ Concr.add lab.txt local_vals)
| Pcf_virt (lab, priv, sty) ->
let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
(val_env, met_env, par_env,
lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc)
::fields,
- concr_meths, warn_vals, inher)
+ concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_meth (lab, priv, ovf, expr) ->
+ if Concr.mem lab.txt local_meths then
+ raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
if Concr.mem lab.txt concr_meths then begin
if ovf = Fresh then
Location.prerr_warning loc (Warnings.Method_override [lab.txt])
end else begin
if ovf = Override then
- raise(Error(loc, No_overriding("method", lab.txt)))
+ raise(Error(loc, val_env, No_overriding("method", lab.txt)))
end;
let (_, ty) =
Ctype.filter_self_method val_env lab.txt priv meths self_type
end
| _ -> assert false
with Ctype.Unify trace ->
- raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace)))
+ raise(Error(loc, val_env,
+ Field_type_mismatch ("method", lab.txt, trace)))
end;
let meth_expr = make_method self_loc cl_num expr in
(* backup variables for Pexp_override *)
| Fresh -> false)) loc
end in
(val_env, met_env, par_env, field::fields,
- Concr.add lab.txt concr_meths, warn_vals, inher)
+ Concr.add lab.txt concr_meths, warn_vals, inher,
+ Concr.add lab.txt local_meths, local_vals)
| Pcf_constr (sty, sty') ->
let (cty, cty') = type_constraint val_env sty sty' loc in
(val_env, met_env, par_env,
lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields,
- concr_meths, warn_vals, inher)
+ concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_init expr ->
let expr = make_method self_loc cl_num expr in
Ctype.end_def ();
mkcf (Tcf_init texp) loc
end in
- (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher)
+ (val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
+ inher, local_meths, local_vals)
and class_structure cl_num final val_env met_env loc
{ pcstr_pat = spat; pcstr_fields = str } =
else self_type in
begin try Ctype.unify val_env public_self ty with
Ctype.Unify _ ->
- raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
+ raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
end;
let get_methods ty =
(fst (Ctype.flatten_fields
end;
(* Typing of class fields *)
- let (_, _, _, fields, concr_meths, _, inher) =
+ let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) =
List.fold_left (class_field self_loc cl_num self_type meths vars)
- (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [])
+ (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
+ Concr.empty, Concr.empty)
str
in
Ctype.unify val_env self_type (Ctype.newvar ());
(fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
sign.cty_vars [] in
if mets <> [] || vals <> [] then
- raise(Error(loc, Virtual_class(true, mets, vals)));
+ raise(Error(loc, val_env, Virtual_class(true, mets, vals)));
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
Ctype.unify val_env private_self
(Ctype.newty (Tobject(self_methods, ref None)));
Ctype.unify val_env public_self self_type
- with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
+ with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
end;
end;
Pcl_constr (lid, styl) ->
let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in
if Path.same decl.cty_path unbound_class then
- raise(Error(scl.pcl_loc, Unbound_class_2 lid.txt));
+ raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
let tyl = List.map
(fun sty -> transl_simple_type val_env false sty)
styl
in
let clty' = abbreviate_class_type path params clty in
if List.length params <> List.length tyl then
- raise(Error(scl.pcl_loc,
+ raise(Error(scl.pcl_loc, val_env,
Parameter_arity_mismatch (lid.txt, List.length params,
List.length tyl)));
List.iter2
(fun cty' ty ->
let ty' = cty'.ctyp_type in
try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
- raise(Error(cty'.ctyp_loc, Parameter_mismatch trace)))
+ raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
tyl params;
let cl =
rc {cl_desc = Tcl_ident (path, lid, tyl);
end
pv
in
- let rec not_function = function
+ let not_function = function
Cty_fun _ -> false
| _ -> true
in
(l, Ctype.instance_def pat.pat_type, cl.cl_type);
cl_env = val_env}
| Pcl_apply (scl', sargs) ->
+ if !Clflags.principal then Ctype.begin_def ();
let cl = class_expr cl_num val_env met_env scl' in
+ if !Clflags.principal then begin
+ Ctype.end_def ();
+ generalize_class_type false cl.cl_type;
+ end;
let rec nonopt_labels ls ty_fun =
match ty_fun with
| Cty_fun (l, _, ty_res) ->
true
end
in
- let rec type_args args omitted ty_fun sargs more_sargs =
- match ty_fun with
- | Cty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] ->
+ let rec type_args args omitted ty_fun ty_fun0 sargs more_sargs =
+ match ty_fun, ty_fun0 with
+ | Cty_fun (l, ty, ty_fun), Cty_fun (_, ty0, ty_fun0)
+ when sargs <> [] || more_sargs <> [] ->
let name = Btype.label_name l
and optional =
if Btype.is_optional l then Optional else Required in
if ignore_labels && not (Btype.is_optional l) then begin
match sargs, more_sargs with
(l', sarg0)::_, _ ->
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l')))
+ raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l'))
| _, (l', sarg0)::more_sargs ->
if l <> l' && l' <> "" then
- raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
+ raise(Error(sarg0.pexp_loc, val_env,
+ Apply_wrong_label l'))
else ([], more_sargs,
- Some (type_argument val_env sarg0 ty ty))
+ Some (type_argument val_env sarg0 ty ty0))
| _ ->
assert false
end else try
Btype.extract_label name more_sargs
in (l', sarg0, sargs @ sargs1, sargs2)
in
+ if optional = Required && Btype.is_optional l' then
+ Location.prerr_warning sarg0.pexp_loc
+ (Warnings.Nonoptional_label l);
sargs, more_sargs,
- if Btype.is_optional l' || not (Btype.is_optional l) then
- Some (type_argument val_env sarg0 ty ty)
+ if optional = Required || Btype.is_optional l' then
+ Some (type_argument val_env sarg0 ty ty0)
else
- let ty0 = extract_option_type val_env ty in
- let arg = type_argument val_env sarg0 ty0 ty0 in
+ let ty' = extract_option_type val_env ty
+ and ty0' = extract_option_type val_env ty0 in
+ let arg = type_argument val_env sarg0 ty' ty0' in
Some (option_some arg)
with Not_found ->
sargs, more_sargs,
if Btype.is_optional l &&
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
then
- Some (option_none ty Location.none)
+ Some (option_none ty0 Location.none)
else None
in
- let omitted = if arg = None then (l,ty) :: omitted else omitted in
- type_args ((l,arg,optional)::args) omitted ty_fun sargs more_sargs
+ let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+ type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0
+ sargs more_sargs
| _ ->
match sargs @ more_sargs with
(l, sarg0)::_ ->
if omitted <> [] then
- raise(Error(sarg0.pexp_loc, Apply_wrong_label l))
+ raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
else
- raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
+ raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
| [] ->
(List.rev args,
List.fold_left
(fun ty_fun (l,ty) -> Cty_fun(l,ty,ty_fun))
- ty_fun omitted)
+ ty_fun0 omitted)
in
let (args, cty) =
+ let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
if ignore_labels then
- type_args [] [] cl.cl_type [] sargs
+ type_args [] [] cl.cl_type ty_fun0 [] sargs
else
- type_args [] [] cl.cl_type sargs []
+ type_args [] [] cl.cl_type ty_fun0 sargs []
in
rc {cl_desc = Tcl_apply (cl, args);
cl_loc = scl.pcl_loc;
try
Typecore.type_let val_env rec_flag sdefs None
with Ctype.Unify [(ty, _)] ->
- raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
+ raise(Error(scl.pcl_loc, val_env, Make_nongen_seltype ty))
in
let (vals, met_env) =
List.fold_right
Includeclass.class_types val_env cl.cl_type clty.cltyp_type
with
[] -> ()
- | error -> raise(Error(cl.cl_loc, Class_match_failure error))
+ | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
end;
let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
let temp_abbrev loc env id arity =
let params = ref [] in
- for i = 1 to arity do
+ for _i = 1 to arity do
params := Ctype.newvar () :: !params
done;
let ty = Ctype.newobj (Ctype.newvar ()) in
type_kind = Type_abstract;
type_private = Public;
type_manifest = Some ty;
- type_variance = List.map (fun _ -> true, true, true) !params;
+ type_variance = Misc.replicate_list Variance.full arity;
type_newtype_level = None;
type_loc = loc;
}
in
(!params, ty, env)
-let rec initial_env define_class approx
+let initial_env define_class approx
(res, env) (cl, id, ty_id, obj_id, cl_id) =
(* Temporary abbreviations *)
let arity = List.length (fst cl.pci_params) in
let params, loc = cl.pci_params in
List.map (fun x -> enter_type_variable true loc x.txt) params
with Already_bound ->
- raise(Error(snd cl.pci_params, Repeated_parameter))
+ raise(Error(snd cl.pci_params, env, Repeated_parameter))
in
(* Allow self coercions (only for class declarations) *)
Ctype.end_def ();
let sty = Ctype.self_type typ in
- ignore (Ctype.object_fields sty);
+ (* First generalize the type of the dummy method (cf PR#6123) *)
+ let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+ List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+ fields;
(* Generalize the row variable *)
let rv = Ctype.row_variable sty in
List.iter (Ctype.limited_generalize rv) params;
begin try
List.iter2 (Ctype.unify env) obj_params obj_params'
with Ctype.Unify _ ->
- raise(Error(cl.pci_loc,
+ raise(Error(cl.pci_loc, env,
Bad_parameters (obj_id, constr,
Ctype.newconstr (Path.Pident obj_id)
obj_params')))
begin try
Ctype.unify env ty constr
with Ctype.Unify _ ->
- raise(Error(cl.pci_loc,
+ raise(Error(cl.pci_loc, env,
Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
end
end;
begin try
List.iter2 (Ctype.unify env) cl_params cl_params'
with Ctype.Unify _ ->
- raise(Error(cl.pci_loc,
+ raise(Error(cl.pci_loc, env,
Bad_parameters (cl_id,
Ctype.newconstr (Path.Pident cl_id)
cl_params,
Ctype.unify env ty cl_ty
with Ctype.Unify _ ->
let constr = Ctype.newconstr (Path.Pident cl_id) params in
- raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
+ raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
end
end;
(constructor_type constr obj_type)
(Ctype.instance env constr_type)
with Ctype.Unify trace ->
- raise(Error(cl.pci_loc,
+ raise(Error(cl.pci_loc, env,
Constructor_type_mismatch (cl.pci_name.txt, trace)))
end;
(* Class and class type temporary definitions *)
- let cty_variance = List.map (fun _ -> true, true) params in
+ let cty_variance = List.map (fun _ -> Variance.full) params in
let cltydef =
{clty_params = params; clty_type = class_body typ;
clty_variance = cty_variance;
(fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
sign.cty_vars [] in
if mets <> [] || vals <> [] then
- raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
+ raise(Error(cl.pci_loc, env, Virtual_class(true, mets, vals)));
end;
(* Misc. *)
type_kind = Type_abstract;
type_private = Public;
type_manifest = Some obj_ty;
- type_variance = List.map (fun _ -> true, true, true) obj_params;
+ type_variance = List.map (fun _ -> Variance.full) obj_params;
type_newtype_level = None;
type_loc = cl.pci_loc}
in
type_kind = Type_abstract;
type_private = Public;
type_manifest = Some cl_ty;
- type_variance = List.map (fun _ -> true, true, true) cl_params;
+ type_variance = List.map (fun _ -> Variance.full) cl_params;
type_newtype_level = None;
type_loc = cl.pci_loc}
in
begin try Ctype.collapse_conj_params env clty.cty_params
with Ctype.Unify trace ->
- raise(Error(cl.pci_loc, Non_collapsable_conjunction (id, clty, trace)))
+ raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
end;
List.iter Ctype.generalize clty.cty_params;
- generalize_class_type clty.cty_type;
- begin match clty.cty_new with
- None -> ()
- | Some ty -> Ctype.generalize ty
- end;
+ generalize_class_type true clty.cty_type;
+ Misc.may Ctype.generalize clty.cty_new;
List.iter Ctype.generalize obj_abbr.type_params;
- begin match obj_abbr.type_manifest with
- None -> ()
- | Some ty -> Ctype.generalize ty
- end;
+ Misc.may Ctype.generalize obj_abbr.type_manifest;
List.iter Ctype.generalize cl_abbr.type_params;
- begin match cl_abbr.type_manifest with
- None -> ()
- | Some ty -> Ctype.generalize ty
- end;
+ Misc.may Ctype.generalize cl_abbr.type_manifest;
if not (closed_class clty) then
- raise(Error(cl.pci_loc, Non_generalizable_class (id, clty)));
+ raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
begin match
Ctype.closed_class clty.cty_params
then function ppf -> Printtyp.class_declaration id ppf clty
else function ppf -> Printtyp.cltype_declaration id ppf cltydef
in
- raise(Error(cl.pci_loc, Unbound_type_var(printer, reason)))
+ raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
end;
(id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
in
begin try Ctype.subtype env cl_ty obj_ty ()
with Ctype.Subtype (tr1, tr2) ->
- raise(Typecore.Error(loc, Typecore.Not_subtype(tr1, tr2)))
+ raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
end;
if not (Ctype.opened_object cl_ty) then
- raise(Error(loc, Cannot_coerce_self obj_ty))
+ raise(Error(loc, env, Cannot_coerce_self obj_ty))
end;
(id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, req)
open Format
-let report_error ppf = function
+let report_error env ppf = function
| Repeated_parameter ->
fprintf ppf "A type parameter occurs several times"
| Unconsistent_constraint trace ->
fprintf ppf "The class constraints are not consistent.@.";
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(fun ppf -> fprintf ppf "Type")
(fun ppf -> fprintf ppf "is not compatible with type")
| Field_type_mismatch (k, m, trace) ->
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(function ppf ->
fprintf ppf "The %s %s@ has type" k m)
(function ppf ->
Printtyp.type_expr actual
Printtyp.type_expr expected
| Constructor_type_mismatch (c, trace) ->
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(function ppf ->
fprintf ppf "The expression \"new %s\" has type" c)
(function ppf ->
but is here applied to %i type argument(s)@]"
Printtyp.longident lid expected provided
| Parameter_mismatch trace ->
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(function ppf ->
fprintf ppf "The type parameter")
(function ppf ->
"@[The type of this class,@ %a,@ \
contains non-collapsible conjunctive types in constraints@]"
(Printtyp.class_declaration id) clty;
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(fun ppf -> fprintf ppf "Type")
(fun ppf -> fprintf ppf "is not compatible with type")
| Final_self_clash trace ->
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(function ppf ->
fprintf ppf "This object is expected to have type")
(function ppf ->
"instance variable"
| No_overriding (kind, name) ->
fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+ | Duplicate (kind, name) ->
+ fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+ kind name
+
+let report_error env ppf err =
+ Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
(* *)
(***********************************************************************)
-(* $Id: typeclass.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
open Asttypes
open Types
open Format
| Final_self_clash of (type_expr * type_expr) list
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
+ | Duplicate of string * string
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
-val report_error : formatter -> error -> unit
+val report_error : Env.t -> formatter -> error -> unit
(* *)
(***********************************************************************)
-(* $Id: typecore.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Typechecking for the core language *)
open Misc
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
- | Label_multiply_defined of Longident.t
+ | Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
+ | Wrong_name of string * Path.t * Longident.t
+ | Name_type_mismatch of
+ string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
| Incomplete_format of string
| Bad_conversion of string * int * char
| Undefined_method of type_expr * string
| Not_a_packed_module of type_expr
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
+ | Unqualified_gadt_pattern of Path.t * string
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
(* Forward declaration, to be filled in by Typemod.type_module *)
let snd3 (_,x,_) = x
-let thd4 (_,_, x,_) = x
(* Upper approximation of free identifiers on the parse tree *)
| Pexp_variant (_, eo) -> may expr eo
| Pexp_record (iel, eo) ->
may expr eo; List.iter (fun (_, e) -> expr e) iel
- | Pexp_open (_, e)
+ | Pexp_open (_, _, e)
| Pexp_newtype (_, e)
| Pexp_poly (e, _)
| Pexp_lazy e
let option_none ty loc =
let lid = Longident.Lident "None" in
- let (path, cnone) = Env.lookup_constructor lid Env.initial in
- mkexp (Texp_construct( path, mknoloc lid, cnone, [], false))
+ let cnone = Env.lookup_constructor lid Env.initial in
+ mkexp (Texp_construct(mknoloc lid, cnone, [], false))
ty loc Env.initial
let option_some texp =
let lid = Longident.Lident "Some" in
- let (path, csome) = Env.lookup_constructor lid Env.initial in
- mkexp ( Texp_construct(path, mknoloc lid , csome, [texp],false) )
+ let csome = Env.lookup_constructor lid Env.initial in
+ mkexp ( Texp_construct(mknoloc lid , csome, [texp],false) )
(type_option texp.exp_type) texp.exp_loc texp.exp_env
let extract_option_type env ty =
when Path.same path Predef.path_option -> ty
| _ -> assert false
-let rec extract_label_names sexp env ty =
- let ty = expand_head env ty in
- match ty.desc with
- | Tconstr (path, _, _) ->
- let td = Env.find_type path env in
- begin match td.type_kind with
- | Type_record (fields, _) ->
- List.map (fun (name, _, _) -> name) fields
- | Type_abstract when td.type_manifest <> None ->
- extract_label_names sexp env (expand_head env ty)
- | _ -> assert false
- end
- | _ ->
- assert false
+let extract_concrete_record env ty =
+ match extract_concrete_typedecl env ty with
+ (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+ | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+ match extract_concrete_typedecl env ty with
+ (* exclude exceptions *)
+ (p0, p, {type_kind=Type_variant (_::_ as cstrs)}) -> (p0, p, cstrs)
+ | _ -> raise Not_found
+
+let extract_label_names sexp env ty =
+ try
+ let (_, _,fields) = extract_concrete_record env ty in
+ List.map (fun (name, _, _) -> name) fields
+ with Not_found ->
+ assert false
(* Typing of patterns *)
unify env ty ty'
with
Unify trace ->
- raise(Error(loc, Pattern_type_clash(trace)))
+ raise(Error(loc, env, Pattern_type_clash(trace)))
| Tags(l1,l2) ->
- raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+ raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
(* unification inside type_exp and type_expect *)
let unify_exp_types loc env ty expected_ty =
unify env ty expected_ty
with
Unify trace ->
- raise(Error(loc, Expr_type_clash(trace)))
+ raise(Error(loc, env, Expr_type_clash(trace)))
| Tags(l1,l2) ->
- raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+ raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
(* level at which to create the local type declarations *)
let newtype_level = ref None
unify_gadt ~newtype_level env ty ty'
with
Unify trace ->
- raise(Error(loc, Pattern_type_clash(trace)))
+ raise(Error(loc, !env, Pattern_type_clash(trace)))
| Tags(l1,l2) ->
- raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+ raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
| Unification_recursive_abbrev trace ->
- raise(Error(loc, Recursive_local_constraint trace))
+ raise(Error(loc, !env, Recursive_local_constraint trace))
(* Creating new conjunctive types is not allowed when typing patterns *)
| _ -> assert false
in
begin match row_field tag row with
- | Rabsent -> assert false
+ | Rabsent -> () (* assert false *)
| Reither (true, [], _, e) when not row.row_closed ->
set_row_field e (Rpresent None)
| Reither (false, ty::tl, _, e) when not row.row_closed ->
let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt)
!pattern_variables
- then raise(Error(loc, Multiply_bound_variable name.txt));
+ then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
let id = Ident.create name.txt in
pattern_variables :=
(id, ty, name, loc, is_as_variable) :: !pattern_variables;
if is_module then begin
(* Note: unpack patterns enter a variable of the same name *)
- if not !allow_modules then raise (Error (loc, Modules_not_allowed));
+ if not !allow_modules then
+ raise (Error (loc, Env.empty, Modules_not_allowed));
module_variables := (name, loc) :: !module_variables
end else
(* moved to genannot *)
unify env t1 t2
with
| Unify trace ->
- raise(Error(loc, Pattern_type_clash(trace)))
+ raise(Error(loc, env, Pattern_type_clash(trace)))
end;
(x2,x1)::unify_vars rem1 rem2
end
| [],[] -> []
- | (x,_,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
- | [],(x,_,_,_,_)::_ -> raise (Error (loc, Orpat_vars x))
+ | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x))
+ | [],(x,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars x))
| (x,_,_,_,_)::_, (y,_,_,_,_)::_ ->
let min_var =
if Ident.name x < Ident.name y then x
else y in
- raise (Error (loc, Orpat_vars min_var)) in
+ raise (Error (loc, env, Orpat_vars min_var)) in
unify_vars p1_vs p2_vs
let rec build_as_type env p =
| Tpat_tuple pl ->
let tyl = List.map (build_as_type env) pl in
newty (Ttuple tyl)
- | Tpat_construct(_, _, cstr, pl,_) ->
+ | Tpat_construct(_, cstr, pl,_) ->
let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
if keep then p.pat_type else
let tyl = List.map (build_as_type env) pl in
row_bound=(); row_name=None;
row_fixed=false; row_closed=false})
| Tpat_record (lpl,_) ->
- let lbl = thd4 (List.hd lpl) in
+ let lbl = snd3 (List.hd lpl) in
if lbl.lbl_private = Private then p.pat_type else
let ty = newvar () in
- let ppl = List.map (fun (_, _, l, p) -> l.lbl_pos, p) lpl in
+ let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
let do_label lbl =
let _, ty_arg, ty_res = instance_label false lbl in
unify_pat env {p with pat_type = ty} ty_res;
let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
match ty.desc with
Tvariant row when static_row row -> row
- | _ -> raise(Error(loc, Not_a_variant_type lid))
+ | _ -> raise(Error(loc, env, Not_a_variant_type lid))
in
let pats, fields =
List.fold_left
pats
in
match pats with
- [] -> raise(Error(loc, Not_a_variant_type lid))
+ [] -> raise(Error(loc, env, Not_a_variant_type lid))
| pat :: pats ->
let r =
List.fold_left
pat pats in
(path, rp { r with pat_loc = loc },ty)
+(* Type paths *)
+
+let rec expand_path env p =
+ let decl =
+ try Some (Env.find_type p env) with Not_found -> None
+ in
+ match decl with
+ Some {type_manifest = Some ty} ->
+ begin match repr ty with
+ {desc=Tconstr(p,_,_)} -> expand_path env p
+ | _ -> assert false
+ end
+ | _ -> p
+
+let compare_type_path env tpath1 tpath2 =
+ Path.same (expand_path env tpath1) (expand_path env tpath2)
+
(* Records *)
+module NameChoice(Name : sig
+ type t
+ val type_kind: string
+ val get_name: t -> string
+ val get_type: t -> type_expr
+ val get_descrs: Env.type_descriptions -> t list
+ val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a
+ val unbound_name_error: Env.t -> Longident.t loc -> 'a
+end) = struct
+ open Name
+
+ let get_type_path env d =
+ match (get_type d).desc with
+ | Tconstr(p, _, _) -> p
+ | _ -> assert false
+
+ let spellcheck ppf env p lid =
+ Typetexp.spellcheck_simple ppf fold
+ (fun d ->
+ if compare_type_path env p (get_type_path env d)
+ then get_name d else "") env lid
+
+ let lookup_from_type env tpath lid =
+ let descrs = get_descrs (Env.find_type_descrs tpath env) in
+ Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
+ match lid.txt with
+ Longident.Lident s -> begin
+ try
+ List.find (fun nd -> get_name nd = s) descrs
+ with Not_found ->
+ raise (Error (lid.loc, env, Wrong_name (type_kind, tpath, lid.txt)))
+ end
+ | _ -> raise Not_found
+
+ let rec unique eq acc = function
+ [] -> List.rev acc
+ | x :: rem ->
+ if List.exists (eq x) acc then unique eq acc rem
+ else unique eq (x :: acc) rem
+
+ let ambiguous_types env lbl others =
+ let tpath = get_type_path env lbl in
+ let others =
+ List.map (fun (lbl, _) -> get_type_path env lbl) others in
+ let tpaths = unique (compare_type_path env) [tpath] others in
+ match tpaths with
+ [_] -> []
+ | _ -> List.map Printtyp.string_of_path tpaths
+
+ let disambiguate_by_type env tpath lbls =
+ let check_type (lbl, _) =
+ let lbl_tpath = get_type_path env lbl in
+ compare_type_path env tpath lbl_tpath
+ in
+ List.find check_type lbls
+
+ let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ())
+ ?scope lid env opath lbls =
+ let scope = match scope with None -> lbls | Some l -> l in
+ let lbl = match opath with
+ None ->
+ begin match lbls with
+ [] -> unbound_name_error env lid
+ | (lbl, use) :: rest ->
+ use ();
+ let paths = ambiguous_types env lbl rest in
+ if paths <> [] then
+ warn lid.loc
+ (Warnings.Ambiguous_name ([Longident.last lid.txt],
+ paths, false));
+ lbl
+ end
+ | Some(tpath0, tpath, pr) ->
+ let warn_pr () =
+ let kind = if type_kind = "record" then "field" else "constructor" in
+ warn lid.loc
+ (Warnings.Not_principal
+ ("this type-based " ^ kind ^ " disambiguation"))
+ in
+ try
+ let lbl, use = disambiguate_by_type env tpath scope in
+ use ();
+ if not pr then begin
+ (* Check if non-principal type is affecting result *)
+ match lbls with
+ [] -> warn_pr ()
+ | (lbl', use') :: rest ->
+ let lbl_tpath = get_type_path env lbl' in
+ if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
+ else
+ let paths = ambiguous_types env lbl rest in
+ if paths <> [] then
+ warn lid.loc
+ (Warnings.Ambiguous_name ([Longident.last lid.txt],
+ paths, false))
+ end;
+ lbl
+ with Not_found -> try
+ let lbl = lookup_from_type env tpath lid in
+ check_lk tpath lbl;
+ let s = Printtyp.string_of_path tpath in
+ warn lid.loc
+ (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));
+ if not pr then warn_pr ();
+ lbl
+ with Not_found ->
+ if lbls = [] then unbound_name_error env lid else
+ let tp = (tpath0, expand_path env tpath) in
+ let tpl =
+ List.map
+ (fun (lbl, _) ->
+ let tp0 = get_type_path env lbl in
+ let tp = expand_path env tp0 in
+ (tp0, tp))
+ lbls
+ in
+ raise (Error (lid.loc, env,
+ Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
+ in
+ begin match scope with
+ (lab1,_)::_ when lab1 == lbl -> ()
+ | _ ->
+ Location.prerr_warning lid.loc
+ (Warnings.Disambiguated_name(get_name lbl))
+ end;
+ lbl
+end
+
+module Label = NameChoice (struct
+ type t = label_description
+ let type_kind = "record"
+ let get_name lbl = lbl.lbl_name
+ let get_type lbl = lbl.lbl_res
+ let get_descrs = snd
+ let fold = Env.fold_labels
+ let unbound_name_error = Typetexp.unbound_label_error
+end)
+
+let disambiguate_label_by_ids keep env closed ids labels =
+ let check_ids (lbl, _) =
+ let lbls = Hashtbl.create 8 in
+ Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+ List.for_all (Hashtbl.mem lbls) ids
+ and check_closed (lbl, _) =
+ (not closed || List.length ids = Array.length lbl.lbl_all)
+ in
+ let labels' = List.filter check_ids labels in
+ if keep && labels' = [] then (false, labels) else
+ let labels'' = List.filter check_closed labels' in
+ if keep && labels'' = [] then (false, labels') else (true, labels'')
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env opath lid_a_list =
+ let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+ let w_pr = ref false and w_amb = ref []
+ and w_scope = ref [] and w_scope_ty = ref "" in
+ let warn loc msg =
+ let open Warnings in
+ match msg with
+ | Not_principal _ -> w_pr := true
+ | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
+ | Name_out_of_scope(ty, [s], _) ->
+ w_scope := s :: !w_scope; w_scope_ty := ty
+ | _ -> Location.prerr_warning loc msg
+ in
+ let process_label lid =
+ (* Strategy for each field:
+ * collect all the labels in scope for that name
+ * if the type is known and principal, just eventually warn
+ if the real label was not in scope
+ * fail if there is no known type and no label found
+ * otherwise use other fields to reduce the list of candidates
+ * if there is no known type reduce it incrementally, so that
+ there is still at least one candidate (for error message)
+ * if the reduced list is valid, call Label.disambiguate
+ *)
+ let scope = Typetexp.find_all_labels env lid.loc lid.txt in
+ if opath = None && scope = [] then
+ Typetexp.unbound_label_error env lid;
+ let (ok, labels) =
+ match opath with
+ Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
+ | _ -> disambiguate_label_by_ids (opath=None) env closed ids scope
+ in
+ if ok then Label.disambiguate lid env opath labels ~warn ~scope
+ else fst (List.hd labels) (* will fail later *)
+ in
+ let lbl_a_list =
+ List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+ if !w_pr then
+ Location.prerr_warning loc
+ (Warnings.Not_principal "this type-based record disambiguation")
+ else begin
+ match List.rev !w_amb with
+ (_,types)::others as amb ->
+ let paths =
+ List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in
+ let path = List.hd paths in
+ if List.for_all (compare_type_path env path) (List.tl paths) then
+ Location.prerr_warning loc
+ (Warnings.Ambiguous_name (List.map fst amb, types, true))
+ else
+ List.iter
+ (fun (s,l) -> Location.prerr_warning loc
+ (Warnings.Ambiguous_name ([s],l,false)))
+ amb
+ | _ -> ()
+ end;
+ if !w_scope <> [] then
+ Location.prerr_warning loc
+ (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+ lbl_a_list
+
let rec find_record_qual = function
| [] -> None
| ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
| _ :: rest -> find_record_qual rest
-let type_label_a_list ?labels env type_lbl_a lid_a_list =
- let record_qual = find_record_qual lid_a_list in
+let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list =
let lbl_a_list =
- List.map
- (fun (lid, a) ->
- let path, label =
- match lid.txt, labels, record_qual with
- Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
- (Hashtbl.find labels s : Path.t * Types.label_description)
- | Longident.Lident s, _, Some modname ->
- Typetexp.find_label env lid.loc (Longident.Ldot (modname, s))
- | _ ->
- Typetexp.find_label env lid.loc lid.txt
- in (path, lid, label, a)
- ) lid_a_list in
+ match lid_a_list, labels with
+ ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+ (* Special case for rebuilt syntax trees *)
+ List.map
+ (function lid, a -> match lid.txt with
+ Longident.Lident s -> lid, Hashtbl.find labels s, a
+ | _ -> assert false)
+ lid_a_list
+ | _ ->
+ let lid_a_list =
+ match find_record_qual lid_a_list with
+ None -> lid_a_list
+ | Some modname ->
+ List.map
+ (fun (lid, a as lid_a) ->
+ match lid.txt with Longident.Lident s ->
+ {lid with txt=Longident.Ldot (modname, s)}, a
+ | _ -> lid_a)
+ lid_a_list
+ in
+ disambiguate_lid_a_list loc closed env opath lid_a_list
+ in
(* Invariant: records are sorted in the typed tree *)
let lbl_a_list =
List.sort
- (fun ( _, _, lbl1,_) ( _,_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+ (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
lbl_a_list
in
List.map type_lbl_a lbl_a_list
;;
-let lid_of_label label =
- match repr label.lbl_res with
- | {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} ->
- Longident.Ldot(lid_of_path mpath, label.lbl_name)
- | _ -> Longident.Lident label.lbl_name
-
(* Checks over the labels mentioned in a record pattern:
no duplicate definitions (error); properly closed (warning) *)
let check_recordpat_labels loc lbl_pat_list closed =
match lbl_pat_list with
| [] -> () (* should not happen *)
- | (_, _, label1, _) :: _ ->
+ | (_, label1, _) :: _ ->
let all = label1.lbl_all in
let defined = Array.make (Array.length all) false in
- let check_defined (_, _, label, _) =
+ let check_defined (_, label, _) =
if defined.(label.lbl_pos)
- then raise(Error(loc, Label_multiply_defined
- (Longident.Lident label.lbl_name)))
+ then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
else defined.(label.lbl_pos) <- true in
List.iter check_defined lbl_pat_list;
if closed = Closed
end
end
+(* Constructors *)
+
+let lookup_constructor_from_type env tpath lid =
+ let (constructors, _) = Env.find_type_descrs tpath env in
+ match lid with
+ Longident.Lident s ->
+ List.find (fun cstr -> cstr.cstr_name = s) constructors
+ | _ -> raise Not_found
+
+module Constructor = NameChoice (struct
+ type t = constructor_description
+ let type_kind = "variant"
+ let get_name cstr = cstr.cstr_name
+ let get_type cstr = cstr.cstr_res
+ let get_descrs = fst
+ let fold = Env.fold_constructors
+ let unbound_name_error = Typetexp.unbound_constructor_error
+end)
+
(* unification of a type with a tconstr with
freshly created arguments *)
let unify_head_only loc env ty constr =
pat_type = expected_ty;
pat_env = !env }
| Ppat_construct(lid, sarg, explicit_arity) ->
- let (constr_path, constr) =
+ let opath =
+ try
+ let (p0, p, _) = extract_concrete_variant !env expected_ty in
+ Some (p0, p, true)
+ with Not_found -> None
+ in
+ let constrs =
match lid.txt, constrs with
Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
- Hashtbl.find constrs s
- | _ -> Typetexp.find_constructor !env loc lid.txt
+ [Hashtbl.find constrs s, (fun () -> ())]
+ | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
+ in
+ let check_lk tpath constr =
+ if constr.cstr_generalized then
+ raise (Error (lid.loc, !env,
+ Unqualified_gadt_pattern (tpath, constr.cstr_name)))
in
+ let constr =
+ Constructor.disambiguate lid !env opath constrs ~check_lk in
Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
if no_existentials && constr.cstr_existentials <> [] then
- raise (Error (loc, Unexpected_existential));
+ raise (Error (loc, !env, Unexpected_existential));
(* if constructor is gadt, we must verify that the expected type has the
correct head *)
if constr.cstr_generalized then
replicate_list sp constr.cstr_arity
| Some sp -> [sp] in
if List.length sargs <> constr.cstr_arity then
- raise(Error(loc, Constructor_arity_mismatch(lid.txt,
+ raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
constr.cstr_arity, List.length sargs)));
let (ty_args, ty_res) =
instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
unify_pat_types loc !env ty_res expected_ty;
let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in
rp {
- pat_desc=Tpat_construct(constr_path, lid, constr, args,explicit_arity);
+ pat_desc=Tpat_construct(lid, constr, args,explicit_arity);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_env = !env }
pat_type = expected_ty;
pat_env = !env }
| Ppat_record(lid_sp_list, closed) ->
- let type_label_pat (label_path, label_lid, label, sarg) =
+ let opath, record_ty =
+ try
+ let (p0, p,_) = extract_concrete_record !env expected_ty in
+ Some (p0, p, true), expected_ty
+ with Not_found -> None, newvar ()
+ in
+ let type_label_pat (label_lid, label, sarg) =
begin_def ();
let (vars, ty_arg, ty_res) = instance_label false label in
if vars = [] then end_def ();
begin try
- unify_pat_types loc !env ty_res expected_ty
+ unify_pat_types loc !env ty_res record_ty
with Unify trace ->
- raise(Error(loc, Label_mismatch(lid_of_label label, trace)))
+ raise(Error(label_lid.loc, !env,
+ Label_mismatch(label_lid.txt, trace)))
end;
let arg = type_pat sarg ty_arg in
if vars <> [] then begin
let tv = expand_head !env tv in
not (is_Tvar tv) || tv.level <> generic_level in
if List.exists instantiated vars then
- raise (Error(loc, Polymorphic_label (lid_of_label label)))
+ raise (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt))
end;
- (label_path, label_lid, label, arg)
+ (label_lid, label, arg)
in
let lbl_pat_list =
- type_label_a_list ?labels !env type_label_pat lid_sp_list in
+ type_label_a_list ?labels loc false !env type_label_pat opath
+ lid_sp_list in
check_recordpat_labels loc lbl_pat_list closed;
+ unify_pat_types loc !env record_ty expected_ty;
rp {
pat_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[];
let add_pattern_variables ?check ?check_as env =
let pv = get_ref pattern_variables in
(List.fold_right
- (fun (id, ty, name, loc, as_var) env ->
+ (fun (id, ty, name, loc, as_var) env ->
let check = if as_var then check_as else check in
- let e1 = Env.add_value ?check id
- {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env in
- Env.add_annot id (Annot.Iref_internal loc) e1)
- pv env,
+ Env.add_value ?check id
+ {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env
+ )
+ pv env,
get_ref module_variables)
let type_pattern ~lev env spat scope expected_ty =
let fst3 (x, _, _) = x
let snd3 (_, x, _) = x
+let rec final_subexpression sexp =
+ match sexp.pexp_desc with
+ Pexp_let (_, _, e)
+ | Pexp_sequence (_, e)
+ | Pexp_try (e, _)
+ | Pexp_ifthenelse (_, e, _)
+ | Pexp_match (_, (_, e) :: _)
+ -> final_subexpression e
+ | _ -> sexp
+
(* Generalization criterion for expressions *)
let rec is_nonexpansive exp =
| Texp_function _ -> true
| Texp_apply(e, (_,None,_)::el) ->
is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el)
+ | Texp_match(e, pat_exp_list, _) ->
+ is_nonexpansive e &&
+ List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list
| Texp_tuple el ->
List.for_all is_nonexpansive el
- | Texp_construct(_, _, _, el,_) ->
+ | Texp_construct( _, _, el,_) ->
List.for_all is_nonexpansive el
| Texp_variant(_, arg) -> is_nonexpansive_opt arg
| Texp_record(lbl_exp_list, opt_init_exp) ->
List.for_all
- (fun (_, _, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
+ (fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
lbl_exp_list
&& is_nonexpansive_opt opt_init_exp
- | Texp_field(exp, _, lbl, _) -> is_nonexpansive exp
+ | Texp_field(exp, lbl, _) -> is_nonexpansive exp
| Texp_array [] -> true
| Texp_ifthenelse(cond, ifso, ifnot) ->
is_nonexpansive ifso && is_nonexpansive_opt ifnot
let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
let bad_conversion fmt i c =
- raise (Error (loc, Bad_conversion (fmt, i, c))) in
+ raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in
let incomplete_format fmt =
- raise (Error (loc, Incomplete_format fmt)) in
+ raise (Error (loc, Env.empty, Incomplete_format fmt)) in
let rec type_in_format fmt =
match fmt.[j] with
| ']' -> scan_closing (j + 1)
| c -> scan_closing j in
- let rec scan_first_neg j =
+ let scan_first_neg j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '^' -> scan_first_pos (j + 1)
and ty1 = approx_ty_opt sty1
and ty2 = approx_ty_opt sty2 in
begin try unify env ty ty1 with Unify trace ->
- raise(Error(sexp.pexp_loc, Expr_type_clash trace))
+ raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
end;
if sty2 = None then ty1 else ty2
| _ -> newvar ()
if List.length vars = List.length vars' then () else
let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
and ty_expected = repr ty_expected in
- raise (Error (exp.exp_loc,
+ raise (Error (exp.exp_loc, env,
Less_general(kind, [ty, ty; ty_expected, ty_expected])))
(* Check that a type is not a function *)
sexp unpacks
(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+ let rec loop ty =
+ let ty = repr ty in
+ if ty.level >= lowest_level then begin
+ mark_type_node ty;
+ match ty.desc with
+ Tvariant row ->
+ let row = row_repr row in
+ if not row.row_fixed then
+ List.iter
+ (fun (_,f) ->
+ match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+ row.row_fields;
+ iter_row loop row
+ | _ ->
+ iter_type_expr loop ty
+ end
+ in
+ try loop ty; unmark_type ty; false
+ with Exit -> unmark_type ty; true
+
let iter_ppat f p =
match p.ppat_desc with
| Ppat_any | Ppat_var _ | Ppat_constant _
match p.ppat_desc with
Ppat_construct (lid, _, _) ->
begin try
- let (_path, cstr) = Env.lookup_constructor lid.txt env in
- if cstr.cstr_generalized then raise Exit
+ let cstrs = Env.lookup_all_constructors lid.txt env in
+ List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
+ cstrs
with Not_found -> ()
end; iter_ppat loop p
| _ -> iter_ppat loop p
in
try loop p; false with Exit -> true
+let check_absent_variant env =
+ iter_pattern
+ (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
+ let row = row_repr !row in
+ if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+ row.row_fields
+ || not row.row_fixed && not (static_row row) (* same as Ctype.poly *)
+ then () else
+ let ty_arg =
+ match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+ let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+ row_more = newvar (); row_bound = ();
+ row_closed = false; row_fixed = false; row_name = None} in
+ (* Should fail *)
+ unify_pat env {pat with pat_type = newty (Tvariant row')}
+ (correct_levels pat.pat_type)
+ | _ -> ())
+
+
let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
(* Duplicate types of values in the environment *)
*)
and type_expect ?in_function env sexp ty_expected =
+ let previous_saved_types = Cmt_format.get_saved_types () in
+ let exp = type_expect_ ?in_function env sexp ty_expected in
+ Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types);
+ exp
+
+and type_expect_ ?in_function env sexp ty_expected =
let loc = sexp.pexp_loc in
(* Record the expression type before unifying it with the expected type *)
let rue exp =
- Cmt_format.add_saved_type (Cmt_format.Partial_expression exp);
- Stypes.record (Stypes.Ti_expr exp);
- unify_exp env exp (instance env ty_expected);
+ unify_exp env (re exp) (instance env ty_expected);
exp
in
match sexp.pexp_desc with
| Pexp_ident lid ->
begin
+ let (path, desc) = Typetexp.find_value env loc lid.txt in
if !Clflags.annotations then begin
- try let (path, annot) = Env.lookup_annot lid.txt env in
- Stypes.record
- (Stypes.An_ident (
- loc, Path.name ~paren:Oprint.parenthesized_ident path, annot))
- with _ -> ()
+ let dloc = desc.Types.val_loc in
+ let annot =
+ if dloc.Location.loc_ghost then Annot.Iref_external
+ else Annot.Iref_internal dloc
+ in
+ let name = Path.name ~paren:Oprint.parenthesized_ident path in
+ Stypes.record (Stypes.An_ident (loc, name, annot))
end;
- let (path, desc) = Typetexp.find_value env loc lid.txt in
rue {
exp_desc =
begin match desc.val_kind with
in
Texp_ident(path, lid, desc)
| Val_unbound ->
- raise(Error(loc, Masked_instance_variable lid.txt))
+ raise(Error(loc, env, Masked_instance_variable lid.txt))
| _ ->
Texp_ident(path, lid, desc)
end;
with Unify _ ->
match expand_head env ty_expected with
{desc = Tarrow _} as ty ->
- raise(Error(loc, Abstract_wrong_label(l, ty)))
+ raise(Error(loc, env, Abstract_wrong_label(l, ty)))
| _ ->
- raise(Error(loc_fun,
+ raise(Error(loc_fun, env,
Too_many_arguments (in_function <> None, ty_fun)))
in
let ty_arg =
exp_env = env }
end
| Pexp_record(lid_sexp_list, opt_sexp) ->
+ let opt_exp =
+ match opt_sexp with
+ None -> None
+ | Some sexp ->
+ if !Clflags.principal then begin_def ();
+ let exp = type_exp env sexp in
+ if !Clflags.principal then begin
+ end_def ();
+ generalize_structure exp.exp_type
+ end;
+ Some exp
+ in
+ let ty_record, opath =
+ let get_path ty =
+ try
+ let (p0, p,_) = extract_concrete_record env ty in
+ (* XXX level may be wrong *)
+ Some (p0, p, ty.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ match get_path ty_expected with
+ None ->
+ let op =
+ match opt_exp with
+ None -> None
+ | Some exp -> get_path exp.exp_type
+ in
+ newvar (), op
+ | op -> ty_expected, op
+ in
+ let closed = (opt_sexp = None) in
let lbl_exp_list =
- type_label_a_list env (type_label_exp true env loc ty_expected)
- lid_sexp_list in
- let rec check_duplicates seen_pos lid_sexp lbl_exp =
- match (lid_sexp, lbl_exp) with
- ((lid, _) :: rem1, (_, _, lbl, _) :: rem2) ->
- if List.mem lbl.lbl_pos seen_pos
- then raise(Error(loc, Label_multiply_defined lid.txt))
- else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
- | (_, _) -> () in
- check_duplicates [] lid_sexp_list lbl_exp_list;
+ type_label_a_list loc closed env
+ (type_label_exp true env loc ty_record)
+ opath lid_sexp_list in
+ unify_exp_types loc env ty_record (instance env ty_expected);
+
+ (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+ (* note: check_duplicates would better be implemented in
+ type_label_a_list directly *)
+ let rec check_duplicates = function
+ | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+ raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
+ | _ :: rem ->
+ check_duplicates rem
+ | [] -> ()
+ in
+ check_duplicates lbl_exp_list;
let opt_exp =
- match opt_sexp, lbl_exp_list with
+ match opt_exp, lbl_exp_list with
None, _ -> None
- | Some sexp, (_, _, lbl, _) :: _ ->
- if !Clflags.principal then begin_def ();
- let ty_exp = newvar () in
+ | Some exp, (lid, lbl, lbl_exp) :: _ ->
+ let ty_exp = instance env exp.exp_type in
let unify_kept lbl =
+ (* do not connect overridden labels *)
if List.for_all
- (fun (_, _, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
+ (fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
lbl_exp_list
then begin
let _, ty_arg1, ty_res1 = instance_label false lbl
and _, ty_arg2, ty_res2 = instance_label false lbl in
- unify env ty_exp ty_res1;
+ unify env ty_arg1 ty_arg2;
unify env (instance env ty_expected) ty_res2;
- unify env ty_arg1 ty_arg2
+ unify_exp_types exp.exp_loc env ty_exp ty_res1;
end in
Array.iter unify_kept lbl.lbl_all;
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty_exp
- end;
- Some(type_expect env sexp ty_exp)
+ Some {exp with exp_type = ty_exp}
| _ -> assert false
in
let num_fields =
match lbl_exp_list with [] -> assert false
- | (_,_, lbl,_)::_ -> Array.length lbl.lbl_all in
+ | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
let present_indices =
- List.map (fun (_,_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
+ List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
let label_names = extract_label_names sexp env ty_expected in
let rec missing_labels n = function
[] -> []
else lbl :: missing_labels (n + 1) rem
in
let missing = missing_labels 0 label_names in
- raise(Error(loc, Label_missing missing))
+ raise(Error(loc, env, Label_missing missing))
end
else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
Location.prerr_warning loc Warnings.Useless_record_with;
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_env = env }
- | Pexp_field(sarg, lid) ->
- let arg = type_exp env sarg in
- let (label_path,label) = Typetexp.find_label env loc lid.txt in
+ | Pexp_field(srecord, lid) ->
+ let (record, label, _) = type_label_access env loc srecord lid in
let (_, ty_arg, ty_res) = instance_label false label in
- unify_exp env arg ty_res;
+ unify_exp env record ty_res;
rue {
- exp_desc = Texp_field(arg, label_path, lid, label);
+ exp_desc = Texp_field(record, lid, label);
exp_loc = loc; exp_extra = [];
exp_type = ty_arg;
exp_env = env }
| Pexp_setfield(srecord, lid, snewval) ->
- let record = type_exp env srecord in
- let (label_path, label) = Typetexp.find_label env loc lid.txt in
- let (label_path, label_loc, label, newval) =
- type_label_exp false env loc record.exp_type
- (label_path, lid, label, snewval) in
+ let (record, label, opath) = type_label_access env loc srecord lid in
+ let ty_record = if opath = None then newvar () else record.exp_type in
+ let (label_loc, label, newval) =
+ type_label_exp false env loc ty_record (lid, label, snewval) in
+ unify_exp env record ty_record;
if label.lbl_mut = Immutable then
- raise(Error(loc, Label_not_mutable lid.txt));
+ raise(Error(loc, env, Label_not_mutable lid.txt));
rue {
- exp_desc = Texp_setfield(record, label_path, label_loc, label, newval);
+ exp_desc = Texp_setfield(record, label_loc, label, newval);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_env = env }
exp_type = instance_def Predef.type_unit;
exp_env = env }
| Pexp_constraint(sarg, sty, sty') ->
-
let separate = true (* always separate, 1% slowdown for lablgtk *)
(* !Clflags.principal || Env.has_local_constraints env *) in
let (arg, ty',cty,cty') =
(Warnings.Not_principal "this ground coercion");
with Subtype (tr1, tr2) ->
(* prerr_endline "coercion failed"; *)
- raise(Error(loc, Not_subtype(tr1, tr2)))
+ raise(Error(loc, env, Not_subtype(tr1, tr2)))
end;
| _ ->
let ty, b = enlarge_type env ty' in
force ();
begin try Ctype.unify env arg.exp_type ty with Unify trace ->
- raise(Error(sarg.pexp_loc,
+ raise(Error(sarg.pexp_loc, env,
Coercion_failure(ty', full_expand env ty', trace, b)))
end
end;
let force'' = subtype env ty ty' in
force (); force' (); force'' ()
with Subtype (tr1, tr2) ->
- raise(Error(loc, Not_subtype(tr1, tr2)))
+ raise(Error(loc, env, Not_subtype(tr1, tr2)))
end;
if separate then begin
end_def ();
| Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
let method_id =
begin try List.assoc met methods with Not_found ->
- raise(Error(e.pexp_loc, Undefined_inherited_method met))
+ raise(Error(e.pexp_loc, env, Undefined_inherited_method met))
end
in
begin match
exp_type = typ;
exp_env = env }
with Unify _ ->
- raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
+ raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met)))
end
| Pexp_new cl ->
let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
begin match cl_decl.cty_new with
None ->
- raise(Error(loc, Virtual_class cl.txt))
+ raise(Error(loc, env, Virtual_class cl.txt))
| Some ty ->
rue {
exp_desc = Texp_new (cl_path, cl, cl_decl);
exp_type = instance_def Predef.type_unit;
exp_env = env }
| Val_ivar _ ->
- raise(Error(loc,Instance_variable_not_mutable(true,lab.txt)))
+ raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
| _ ->
- raise(Error(loc,Instance_variable_not_mutable(false,lab.txt)))
+ raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt)))
with
Not_found ->
- raise(Error(loc, Unbound_instance_variable lab.txt))
+ raise(Error(loc, env, Unbound_instance_variable lab.txt))
end
| Pexp_override lst ->
let _ =
List.fold_right
(fun (lab, _) l ->
if List.exists (fun l -> l.txt = lab.txt) l then
- raise(Error(loc,
+ raise(Error(loc, env,
Value_multiply_overridden lab.txt));
lab::l)
lst
Env.lookup_value (Longident.Lident "selfpat-*") env,
Env.lookup_value (Longident.Lident "self-*") env
with Not_found ->
- raise(Error(loc, Outside_class))
+ raise(Error(loc, env, Outside_class))
with
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
(path_self, _) ->
(Path.Pident id, lab, type_expect env snewval (instance env ty))
with
Not_found ->
- raise(Error(loc, Unbound_instance_variable lab.txt))
+ raise(Error(loc, env, Unbound_instance_variable lab.txt))
end
in
let modifs = List.map type_override lst in
begin try
Ctype.unify_var new_env ty body.exp_type
with Unify _ ->
- raise(Error(loc, Scoping_let_module(name.txt, body.exp_type)))
+ raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
end;
re {
exp_desc = Texp_letmodule(id, name, modl, body);
(Warnings.Not_principal "this module packing");
(p, nl, tl)
| {desc = Tvar _} ->
- raise (Error (loc, Cannot_infer_signature))
+ raise (Error (loc, env, Cannot_infer_signature))
| _ ->
- raise (Error (loc, Not_a_packed_module ty_expected))
+ raise (Error (loc, env, Not_a_packed_module ty_expected))
in
let (modl, tl') = !type_package env m p nl tl in
rue {
exp_loc = loc; exp_extra = [];
exp_type = newty (Tpackage (p, nl, tl'));
exp_env = env }
- | Pexp_open (lid, e) ->
- let (path, newenv) = !type_open env sexp.pexp_loc lid in
+ | Pexp_open (ovf, lid, e) ->
+ let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
let exp = type_expect newenv e ty_expected in
{ exp with
- exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra;
+ exp_extra = (Texp_open (ovf, path, lid, newenv), loc) ::
+ exp.exp_extra;
}
+and type_label_access env loc srecord lid =
+ if !Clflags.principal then begin_def ();
+ let record = type_exp env srecord in
+ if !Clflags.principal then begin
+ end_def ();
+ generalize_structure record.exp_type
+ end;
+ let ty_exp = record.exp_type in
+ let opath =
+ try
+ let (p0, p,_) = extract_concrete_record env ty_exp in
+ Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let labels = Typetexp.find_all_labels env lid.loc lid.txt in
+ let label = Label.disambiguate lid env opath labels in
+ (record, label, opath)
+
and type_label_exp create env loc ty_expected
- (label_path, lid, label, sarg) =
+ (lid, label, sarg) =
(* Here also ty_expected may be at generic_level *)
begin_def ();
let separate = !Clflags.principal || Env.has_local_constraints env in
begin try
unify env (instance_def ty_res) (instance env ty_expected)
with Unify trace ->
- raise (Error(lid.loc, Label_mismatch(lid_of_label label, trace)))
+ raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
end;
(* Instantiate so that we can generalize internal nodes *)
let ty_arg = instance_def ty_arg in
end;
if label.lbl_private = Private then
if create then
- raise (Error(loc, Private_type ty_expected))
+ raise (Error(loc, env, Private_type ty_expected))
else
- raise (Error(lid.loc, Private_label(lid_of_label label, ty_expected)));
+ raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
let arg =
let snap = if vars = [] then None else Some (Btype.snapshot ()) in
let arg = type_argument env sarg ty_arg (instance env ty_arg) in
unify_exp env arg ty_arg;
check_univars env false "field value" arg label.lbl_arg vars;
arg
- with Error (_, Less_general _) as e -> raise e
+ with Error (_, _, Less_general _) as e -> raise e
| _ -> raise exn (* In case of failure return the first error *)
in
- (label_path, lid, label, {arg with exp_type = instance env arg.exp_type})
+ (lid, label, {arg with exp_type = instance env arg.exp_type})
and type_argument env sarg ty_expected' ty_expected =
(* ty_expected' may be generic *)
let rec is_inferred sexp =
match sexp.pexp_desc with
Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true
- | Pexp_open (_, e) -> is_inferred e
+ | Pexp_open (_, _, e) -> is_inferred e
| _ -> false
in
match expand_head env ty_expected' with
let rec make_args args ty_fun =
match (expand_head env ty_fun).desc with
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
- make_args
- ((Some(option_none (instance env ty_arg) sarg.pexp_loc), Optional)
- :: args)
- ty_fun
+ let ty = option_none (instance env ty_arg) sarg.pexp_loc in
+ make_args ((l, Some ty, Optional) :: args) ty_fun
| Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
args, ty_fun, no_labels ty_res'
| Tvar _ -> args, ty_fun, false
{ texp with exp_type = ty_fun; exp_desc =
Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc =
Texp_apply (texp,
- (List.map (fun (label, exp) ->
- ("", label, exp)) args)@
- ["", Some eta_var, Required])}],
+ List.rev args @ ["", Some eta_var, Required])}],
Total) } in
if warn then Location.prerr_warning texp.exp_loc
(Warnings.Without_principality "eliminated optional argument");
if is_nonexpansive texp then func texp else
(* let-expand to have side effects *)
- let let_pat, let_var = var_pair "let" texp.exp_type in
+ let let_pat, let_var = var_pair "arg" texp.exp_type in
re { texp with exp_type = ty_fun; exp_desc =
Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
end
match ty_res.desc with
Tarrow _ ->
if (!Clflags.classic || not (has_label l1 ty_fun)) then
- raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
+ raise (Error(sarg1.pexp_loc, env,
+ Apply_wrong_label(l1, ty_res)))
else
- raise(Error(funct.exp_loc, Incoherent_label_order))
+ raise (Error(funct.exp_loc, env, Incoherent_label_order))
| _ ->
- raise(Error(funct.exp_loc, Apply_non_function
+ raise(Error(funct.exp_loc, env, Apply_non_function
(expand_head env funct.exp_type)))
in
let optional = if is_optional l1 then Optional else Required in
(* In classic mode, omitted = [] *)
match sargs, more_sargs with
(l', sarg0) :: _, _ ->
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
+ raise(Error(sarg0.pexp_loc, env,
+ Apply_wrong_label(l', ty_old)))
| _, (l', sarg0) :: more_sargs ->
if l <> l' && l' <> "" then
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
+ raise(Error(sarg0.pexp_loc, env,
+ Apply_wrong_label(l', ty_fun')))
else
([], more_sargs,
Some (fun () -> type_argument env sarg0 ty ty0))
(Warnings.Not_principal "commuting this argument");
(l', sarg0, sargs @ sargs1, sargs2)
in
+ if optional = Required && is_optional l' then
+ Location.prerr_warning sarg0.pexp_loc
+ (Warnings.Nonoptional_label l);
sargs, more_sargs,
if optional = Required || is_optional l' then
Some (fun () -> type_argument env sarg0 ty ty0)
| _ ->
match sargs with
(l, sarg0) :: _ when ignore_labels ->
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
+ raise(Error(sarg0.pexp_loc, env,
+ Apply_wrong_label(l, ty_old)))
| _ ->
type_unknown_args args omitted ty_fun0
(sargs @ more_sargs)
type_args [] [] ty (instance env ty) ty sargs []
and type_construct env loc lid sarg explicit_arity ty_expected =
- let (path,constr) = Typetexp.find_constructor env loc lid.txt in
+ let opath =
+ try
+ let (p0, p,_) = extract_concrete_variant env ty_expected in
+ Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+ let constr = Constructor.disambiguate lid env opath constrs in
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
let sargs =
match sarg with
| Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
| Some se -> [se] in
if List.length sargs <> constr.cstr_arity then
- raise(Error(loc, Constructor_arity_mismatch
+ raise(Error(loc, env, Constructor_arity_mismatch
(lid.txt, constr.cstr_arity, List.length sargs)));
let separate = !Clflags.principal || Env.has_local_constraints env in
if separate then (begin_def (); begin_def ());
let (ty_args, ty_res) = instance_constructor constr in
let texp =
re {
- exp_desc = Texp_construct(path, lid, constr, [],explicit_arity);
+ exp_desc = Texp_construct(lid, constr, [],explicit_arity);
exp_loc = loc; exp_extra = [];
exp_type = ty_res;
exp_env = env } in
let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs
(List.combine ty_args ty_args0) in
if constr.cstr_private = Private then
- raise(Error(loc, Private_type ty_res));
+ raise(Error(loc, env, Private_type ty_res));
{ texp with
- exp_desc = Texp_construct(path, lid, constr, args, explicit_arity) }
+ exp_desc = Texp_construct(lid, constr, args, explicit_arity) }
(* Typing of statements (expressions whose values are discarded) *)
and type_statement env sexp =
- let loc = sexp.pexp_loc in
+ let loc = (final_subexpression sexp).pexp_loc in
begin_def();
let exp = type_exp env sexp in
end_def();
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
(* ty_arg is _fully_ generalized *)
- let dont_propagate, has_gadts =
- let patterns = List.map fst caselist in
- List.exists contains_polymorphic_variant patterns,
- List.exists (contains_gadt env) patterns in
+ let patterns = List.map fst caselist in
+ let erase_either =
+ List.exists contains_polymorphic_variant patterns
+ && contains_variant_either ty_arg
+ and has_gadts = List.exists (contains_gadt env) patterns in
(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
- let ty_arg, ty_res, env =
+ let ty_arg =
+ if (has_gadts || erase_either) && not !Clflags.principal
+ then correct_levels ty_arg else ty_arg
+ and ty_res, env =
if has_gadts && not !Clflags.principal then
- correct_levels ty_arg, correct_levels ty_res,
- duplicate_ident_types loc caselist env
- else ty_arg, ty_res, env in
+ correct_levels ty_res, duplicate_ident_types loc caselist env
+ else ty_res, env
+ in
let lev, env =
if has_gadts then begin
(* raise level for existentials *)
let scope = Some (Annot.Idef loc) in
let (pat, ext_env, force, unpacks) =
let partial =
- if !Clflags.principal then Some false else None in
- let ty_arg =
- if dont_propagate then newvar () else instance ?partial env ty_arg
- in type_pattern ~lev env spat scope ty_arg
+ if !Clflags.principal || erase_either
+ then Some false else None in
+ let ty_arg = instance ?partial env ty_arg in
+ type_pattern ~lev env spat scope ty_arg
in
pattern_force := force @ !pattern_force;
let pat =
else
Partial
in
- add_delayed_check (fun () -> Parmatch.check_unused env cases);
+ add_delayed_check
+ (fun () ->
+ List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
+ pat_env_list;
+ Parmatch.check_unused env cases);
if has_gadts then begin
end_def ();
(* Ensure that existential types do not escape *)
open Format
open Printtyp
-let report_error ppf = function
+let report_error env ppf = function
| Polymorphic_label lid ->
- fprintf ppf "@[The record field label %a is polymorphic.@ %s@]"
+ fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
longident lid "You cannot instantiate it in a pattern."
| Constructor_arity_mismatch(lid, expected, provided) ->
fprintf ppf
but is applied here to %i argument(s)@]"
longident lid expected provided
| Label_mismatch(lid, trace) ->
- report_unification_error ppf trace
+ report_unification_error ppf env trace
(function ppf ->
- fprintf ppf "The record field label %a@ belongs to the type"
+ fprintf ppf "The record field %a@ belongs to the type"
longident lid)
(function ppf ->
- fprintf ppf "but is mixed here with labels of type")
+ fprintf ppf "but is mixed here with fields of type")
| Pattern_type_clash trace ->
- report_unification_error ppf trace
+ report_unification_error ppf env trace
(function ppf ->
fprintf ppf "This pattern matches values of type")
(function ppf ->
fprintf ppf "Variable %s must occur on both sides of this | pattern"
(Ident.name id)
| Expr_type_clash trace ->
- report_unification_error ppf trace
+ report_unification_error ppf env trace
(function ppf ->
fprintf ppf "This expression has type")
(function ppf ->
fprintf ppf "but an expression was expected of type")
| Apply_non_function typ ->
+ reset_and_mark_loops typ;
begin match (repr typ).desc with
Tarrow _ ->
- fprintf ppf "This function is applied to too many arguments;@ ";
- fprintf ppf "maybe you forgot a `;'"
+ fprintf ppf "@[<v>@[<2>This function has type@ %a@]"
+ type_expr typ;
+ fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]"
+ "maybe you forgot a `;'."
| _ ->
- fprintf ppf
- "This expression is not a function; it cannot be applied"
+ fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
+ type_expr typ
+ "This is not a function; it cannot be applied."
end
| Apply_wrong_label (l, ty) ->
let print_label ppf = function
"@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
This argument cannot be applied %a@]"
type_expr ty print_label l
- | Label_multiply_defined lid ->
- fprintf ppf "The record field label %a is defined several times"
- longident lid
+ | Label_multiply_defined s ->
+ fprintf ppf "The record field label %s is defined several times" s
| Label_missing labels ->
let print_labels ppf =
List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
- fprintf ppf "@[<hov>Some record field labels are undefined:%a@]"
+ fprintf ppf "@[<hov>Some record fields are undefined:%a@]"
print_labels labels
| Label_not_mutable lid ->
- fprintf ppf "The record field label %a is not mutable" longident lid
+ fprintf ppf "The record field %a is not mutable" longident lid
+ | Wrong_name (kind, p, lid) ->
+ fprintf ppf "The %s type %a has no %s %a" kind path p
+ (if kind = "record" then "field" else "constructor")
+ longident lid;
+ if kind = "record" then Label.spellcheck ppf env p lid
+ else Constructor.spellcheck ppf env p lid
+ | Name_type_mismatch (kind, lid, tp, tpl) ->
+ let name = if kind = "record" then "field" else "constructor" in
+ report_ambiguous_type_error ppf env tp tpl
+ (function ppf ->
+ fprintf ppf "The %s %a@ belongs to the %s type"
+ name longident lid kind)
+ (function ppf ->
+ fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+ name longident lid kind)
+ (function ppf ->
+ fprintf ppf "but a %s was expected belonging to the %s type"
+ name kind)
| Incomplete_format s ->
fprintf ppf "Premature end of format string ``%S''" s
| Bad_conversion (fmt, i, c) ->
else
fprintf ppf "The value %s is not an instance variable" v
| Not_subtype(tr1, tr2) ->
- report_subtyping_error ppf tr1 "is not a subtype of" tr2
+ report_subtyping_error ppf env tr1 "is not a subtype of" tr2
| Outside_class ->
fprintf ppf "This object duplication occurs outside a method definition"
| Value_multiply_overridden v ->
fprintf ppf "The instance variable %s is overridden several times" v
| Coercion_failure (ty, ty', trace, b) ->
- report_unification_error ppf trace
+ report_unification_error ppf env trace
(function ppf ->
let ty, ty' = prepare_expansion (ty, ty') in
fprintf ppf
fprintf ppf "in an order different from other calls.@ ";
fprintf ppf "This is only allowed when the real type is known."
| Less_general (kind, trace) ->
- report_unification_error ppf trace
+ report_unification_error ppf env trace
(fun ppf -> fprintf ppf "This %s has type" kind)
(fun ppf -> fprintf ppf "which is less general than")
| Modules_not_allowed ->
"This expression is packed module, but the expected type is@ %a"
type_expr ty
| Recursive_local_constraint trace ->
- report_unification_error ppf trace
+ report_unification_error ppf env trace
(function ppf ->
fprintf ppf "Recursive local constraint when unifying")
(function ppf ->
| Unexpected_existential ->
fprintf ppf
"Unexpected existential"
+ | Unqualified_gadt_pattern (tpath, name) ->
+ fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
+ name path tpath
+ "must be qualified in this pattern"
+
+let report_error env ppf err =
+ wrap_printing_env env (fun () -> report_error env ppf err)
let () =
Env.add_delayed_check_forward := add_delayed_check
(* *)
(***********************************************************************)
-(* $Id: typecore.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
(* Type inference for the core language *)
open Asttypes
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
- | Label_multiply_defined of Longident.t
+ | Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
+ | Wrong_name of string * Path.t * Longident.t
+ | Name_type_mismatch of
+ string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
| Incomplete_format of string
| Bad_conversion of string * int * char
| Undefined_method of type_expr * string
| Not_a_packed_module of type_expr
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
+ | Unqualified_gadt_pattern of Path.t * string
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit
(* Forward declaration, to be filled in by Typemod.type_module *)
val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
(* Forward declaration, to be filled in by Typemod.type_open *)
-val type_open: (Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref
+val type_open:
+ (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t)
+ ref
(* Forward declaration, to be filled in by Typeclass.class_structure *)
val type_object:
(Env.t -> Location.t -> Parsetree.class_structure ->
(* *)
(***********************************************************************)
-(* $Id: typedecl.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(**** Typing of type definitions ****)
open Misc
| Recursive_abbrev of string
| Definition_mismatch of type_expr * Includecore.type_mismatch list
| Constraint_failed of type_expr * type_expr
- | Inconsistent_constraint of (type_expr * type_expr) list
- | Type_clash of (type_expr * type_expr) list
+ | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
+ | Type_clash of Env.t * (type_expr * type_expr) list
| Parameters_differ of Path.t * type_expr * type_expr
| Null_arity_external
| Missing_native_external
| Unbound_type_var of type_expr * type_declaration
| Unbound_exception of Longident.t
| Not_an_exception of Longident.t
- | Bad_variance of int * (bool * bool) * (bool * bool)
+ | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool)
| Unavailable_type_constructor of Path.t
| Bad_fixed_type of string
| Unbound_type_var_exc of type_expr * type_expr
type_manifest =
begin match sdecl.ptype_manifest with None -> None
| Some _ -> Some(Ctype.newvar ()) end;
- type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params;
+ type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
type_newtype_level = None;
type_loc = sdecl.ptype_loc;
}
let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
try Ctype.unify env (Ctype.newconstr path params) ty
with Ctype.Unify trace ->
- raise (Error(loc, Type_clash trace))
+ raise (Error(loc, Type_clash (env, trace)))
(* Determine if a type is (an abbreviation for) the type "float" *)
(* We use the Ctype.expand_head_opt version of expand_head to get access
module StringSet =
Set.Make(struct
type t = string
- let compare = compare
+ let compare (x:t) y = compare x y
end)
let make_params sdecl =
let name = Ident.create lid.txt in
match ret_type with
| None ->
- (name, lid, List.map (transl_simple_type env true) args, None, loc)
+ (name, lid, List.map (transl_simple_type env true) args,
+ None, loc)
| Some sty ->
(* if it's a generalized constructor we must first narrow and
then widen so as to not introduce any new constraints *)
type_kind = kind;
type_private = sdecl.ptype_private;
type_manifest = man;
- type_variance = List.map (fun _ -> true, true, true) params;
+ type_variance = List.map (fun _ -> Variance.full) params;
type_newtype_level = None;
type_loc = sdecl.ptype_loc;
} in
let ty = cty.ctyp_type in
let ty' = cty'.ctyp_type in
try Ctype.unify env ty ty' with Ctype.Unify tr ->
- raise(Error(loc, Inconsistent_constraint tr)))
+ raise(Error(loc, Inconsistent_constraint (env, tr))))
cstrs;
Ctype.end_def ();
(* Add abstract row *)
Btype.iter_type_expr (check_constraints_rec env loc visited) ty
end
+module SMap = Map.Make(String)
+
let check_constraints env (_, sdecl) (_, decl) =
let visited = ref TypeSet.empty in
begin match decl.type_kind with
| Type_abstract -> ()
| Type_variant l ->
- let rec find_pl = function
+ let find_pl = function
Ptype_variant pl -> pl
| Ptype_record _ | Ptype_abstract -> assert false
in
let pl = find_pl sdecl.ptype_kind in
+ let pl_index =
+ let foldf acc (name, styl, sret_type, _) =
+ SMap.add name.txt (styl, sret_type) acc
+ in
+ List.fold_left foldf SMap.empty pl
+ in
List.iter
(fun (name, tyl, ret_type) ->
let (styl, sret_type) =
- try
- let (_, sty, sret_type, _) =
- List.find (fun (n,_,_,_) -> n.txt = Ident.name name) pl
- in (sty, sret_type)
+ try SMap.find (Ident.name name) pl_index
with Not_found -> assert false in
List.iter2
(fun sty ty ->
() )
l
| Type_record (l, _) ->
- let rec find_pl = function
+ let find_pl = function
Ptype_record pl -> pl
| Ptype_variant _ | Ptype_abstract -> assert false
in
need to check that the equation refers to a type of the same kind
with the same constructors and labels.
*)
-let check_abbrev env (_, sdecl) (id, decl) =
+let check_coherence env loc id decl =
match decl with
{type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} ->
begin match (Ctype.repr ty).desc with
(Subst.add_type id path Subst.identity) decl)
in
if err <> [] then
- raise(Error(sdecl.ptype_loc, Definition_mismatch (ty, err)))
+ raise(Error(loc, Definition_mismatch (ty, err)))
with Not_found ->
- raise(Error(sdecl.ptype_loc, Unavailable_type_constructor path))
+ raise(Error(loc, Unavailable_type_constructor path))
end
- | _ -> raise(Error(sdecl.ptype_loc, Definition_mismatch (ty, [])))
+ | _ -> raise(Error(loc, Definition_mismatch (ty, [])))
end
| _ -> ()
+let check_abbrev env (_, sdecl) (id, decl) =
+ check_coherence env sdecl.ptype_loc id decl
+
(* Check that recursion is well-founded *)
let check_well_founded env loc path decl =
try Ctype.correct_abbrev env path decl.type_params body with
| Ctype.Recursive_abbrev ->
raise(Error(loc, Recursive_abbrev (Path.name path)))
- | Ctype.Unify trace -> raise(Error(loc, Type_clash trace)))
+ | Ctype.Unify trace -> raise(Error(loc, Type_clash (env, trace))))
decl.type_manifest
(* Check for ill-defined abbrevs *)
(* Compute variance *)
-let compute_variance env tvl nega posi cntr ty =
- let pvisited = ref TypeSet.empty
- and nvisited = ref TypeSet.empty
- and cvisited = ref TypeSet.empty in
- let rec compute_variance_rec posi nega cntr ty =
+module TypeMap = Btype.TypeMap
+
+let get_variance ty visited =
+ try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+ let rec compute_variance_rec vari ty =
+ (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
let ty = Ctype.repr ty in
- if (not posi || TypeSet.mem ty !pvisited)
- && (not nega || TypeSet.mem ty !nvisited)
- && (not cntr || TypeSet.mem ty !cvisited) then
- ()
- else begin
- if posi then pvisited := TypeSet.add ty !pvisited;
- if nega then nvisited := TypeSet.add ty !nvisited;
- if cntr then cvisited := TypeSet.add ty !cvisited;
- let compute_same = compute_variance_rec posi nega cntr in
- match ty.desc with
- Tarrow (_, ty1, ty2, _) ->
- compute_variance_rec nega posi true ty1;
- compute_same ty2
- | Ttuple tl ->
- List.iter compute_same tl
- | Tconstr (path, tl, _) ->
- if tl = [] then () else begin
- try
- let decl = Env.find_type path env in
- List.iter2
- (fun ty (co,cn,ct) ->
- compute_variance_rec
- (posi && co || nega && cn)
- (posi && cn || nega && co)
- (cntr || ct)
- ty)
- tl decl.type_variance
- with Not_found ->
- List.iter (compute_variance_rec true true true) tl
- end
- | Tobject (ty, _) ->
- compute_same ty
- | Tfield (_, _, ty1, ty2) ->
- compute_same ty1;
- compute_same ty2
- | Tsubst ty ->
- compute_same ty
- | Tvariant row ->
- let row = Btype.row_repr row in
- List.iter
- (fun (_,f) ->
- match Btype.row_field_repr f with
- Rpresent (Some ty) ->
- compute_same ty
- | Reither (_, tyl, _, _) ->
- List.iter compute_same tyl
- | _ -> ())
- row.row_fields;
- compute_same row.row_more
- | Tpoly (ty, _) ->
- compute_same ty
- | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
- | Tpackage (_, _, tyl) ->
- List.iter (compute_variance_rec true true true) tyl
- end
+ let vari' = get_variance ty visited in
+ if Variance.subset vari vari' then () else
+ let vari = Variance.union vari vari' in
+ visited := TypeMap.add ty vari !visited;
+ let compute_same = compute_variance_rec vari in
+ match ty.desc with
+ Tarrow (_, ty1, ty2, _) ->
+ let open Variance in
+ let v = conjugate vari in
+ let v1 =
+ if mem May_pos v || mem May_neg v
+ then set May_weak true v else v
+ in
+ compute_variance_rec v1 ty1;
+ compute_same ty2
+ | Ttuple tl ->
+ List.iter compute_same tl
+ | Tconstr (path, tl, _) ->
+ let open Variance in
+ if tl = [] then () else begin
+ try
+ let decl = Env.find_type path env in
+ let cvari f = mem f vari in
+ List.iter2
+ (fun ty v ->
+ let cv f = mem f v in
+ let strict =
+ cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+ in
+ if strict then compute_variance_rec full ty else
+ let p1 = inter v vari
+ and n1 = inter v (conjugate vari) in
+ let v1 =
+ union (inter covariant (union p1 (conjugate p1)))
+ (inter (conjugate covariant) (union n1 (conjugate n1)))
+ and weak =
+ cvari May_weak && (cv May_pos || cv May_neg) ||
+ (cvari May_pos || cvari May_neg) && cv May_weak
+ in
+ let v2 = set May_weak weak v1 in
+ compute_variance_rec v2 ty)
+ tl decl.type_variance
+ with Not_found ->
+ List.iter (compute_variance_rec may_inv) tl
+ end
+ | Tobject (ty, _) ->
+ compute_same ty
+ | Tfield (_, _, ty1, ty2) ->
+ compute_same ty1;
+ compute_same ty2
+ | Tsubst ty ->
+ compute_same ty
+ | Tvariant row ->
+ let row = Btype.row_repr row in
+ List.iter
+ (fun (_,f) ->
+ match Btype.row_field_repr f with
+ Rpresent (Some ty) ->
+ compute_same ty
+ | Reither (_, tyl, _, _) ->
+ List.iter compute_same tyl
+ | _ -> ())
+ row.row_fields;
+ compute_same row.row_more
+ | Tpoly (ty, _) ->
+ compute_same ty
+ | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+ | Tpackage (_, _, tyl) ->
+ let v =
+ Variance.(if mem Pos vari || mem Neg vari then full else may_inv)
+ in
+ List.iter (compute_variance_rec v) tyl
in
- compute_variance_rec nega posi cntr ty;
- List.iter
- (fun (ty, covar, convar, ctvar) ->
- if TypeSet.mem ty !pvisited then covar := true;
- if TypeSet.mem ty !nvisited then convar := true;
- if TypeSet.mem ty !cvisited then ctvar := true)
- tvl
+ compute_variance_rec vari ty
-let make_variance ty = (ty, ref false, ref false, ref false)
+let make_variance ty = (ty, ref Variance.null)
let whole_type decl =
match decl.type_kind with
Type_variant tll ->
Some ty -> ty
| _ -> Btype.newgenty (Ttuple [])
+let make p n i =
+ let open Variance in
+ set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
let compute_variance_type env check (required, loc) decl tyl =
- let params = List.map Btype.repr decl.type_params in
- let tvl0 = List.map make_variance params in
- let args = Btype.newgenty (Ttuple params) in
- let fvl = if check then Ctype.free_variables args else [] in
- let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
- let tvl1 = List.map make_variance fvl in
- let tvl2 = List.map make_variance fvl in
- let tvl = tvl0 @ tvl1 in
- List.iter (fun (cn,ty) -> compute_variance env tvl true cn cn ty) tyl;
+ (* Requirements *)
let required =
- List.map (fun (c,n as r) -> if c || n then r else (true,true))
+ List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
required
in
- List.iter2
- (fun (ty, co, cn, ct) (c, n) ->
- if not (Btype.is_Tvar ty) then begin
- co := c; cn := n; ct := n;
- compute_variance env tvl2 c n n ty
- end)
- tvl0 required;
- List.iter2
- (fun (ty, c1, n1, t1) (_, c2, n2, t2) ->
- if !c1 && not !c2 || !n1 && not !n2
- then raise (Error(loc, Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
- tvl1 tvl2;
- let pos = ref 0 in
+ (* Prepare *)
+ let params = List.map Btype.repr decl.type_params in
+ let tvl = ref TypeMap.empty in
+ (* Compute occurences in body *)
+ let open Variance in
+ List.iter
+ (fun (cn,ty) ->
+ compute_variance env tvl (if cn then full else covariant) ty)
+ tyl;
+ if check then begin
+ (* Check variance of parameters *)
+ let pos = ref 0 in
+ List.iter2
+ (fun ty (c, n, i) ->
+ incr pos;
+ let var = get_variance ty tvl in
+ let (co,cn) = get_upper var and ij = mem Inj var in
+ if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
+ then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i)))))
+ params required;
+ (* Check propagation from constrained parameters *)
+ let args = Btype.newgenty (Ttuple params) in
+ let fvl = Ctype.free_variables args in
+ let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+ (* If there are no extra variables there is nothing to do *)
+ if fvl = [] then () else
+ let tvl2 = ref TypeMap.empty in
+ List.iter2
+ (fun ty (p,n,i) ->
+ if Btype.is_Tvar ty then () else
+ let v =
+ if p then if n then full else covariant else conjugate covariant in
+ compute_variance env tvl2 v ty)
+ params required;
+ let visited = ref TypeSet.empty in
+ let rec check ty =
+ let ty = Ctype.repr ty in
+ if TypeSet.mem ty !visited then () else
+ let visited' = TypeSet.add ty !visited in
+ visited := visited';
+ let v1 = get_variance ty tvl in
+ let snap = Btype.snapshot () in
+ let v2 =
+ TypeMap.fold
+ (fun t vt v ->
+ if Ctype.equal env false [ty] [t] then union vt v else v)
+ !tvl2 null in
+ Btype.backtrack snap;
+ let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+ if c1 && not c2 || n1 && not n2 then
+ if List.memq ty fvl then
+ let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in
+ raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+ else
+ Btype.iter_type_expr check ty
+ in
+ List.iter (fun (_,ty) -> check ty) tyl;
+ end;
List.map2
- (fun (_, co, cn, ct) (c, n) ->
- incr pos;
- if !co && not c || !cn && not n
- then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n))));
- if decl.type_private = Private then (c,n,n) else
- let ct = if decl.type_kind = Type_abstract then ct else cn in
- (!co, !cn, !ct))
- tvl0 required
+ (fun ty (p, n, i) ->
+ let v = get_variance ty tvl in
+ let tr = decl.type_private in
+ (* Use required variance where relevant *)
+ let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+ let (p, n) =
+ if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+ else (false, false) (* only check *)
+ and i = concr || i && tr = Private in
+ let v = union v (make p n i) in
+ let v =
+ if not concr then v else
+ if mem Pos v && mem Neg v then full else
+ if Btype.is_Tvar ty then v else
+ union v
+ (if p then if n then full else covariant else conjugate covariant)
+ in
+ if decl.type_kind = Type_abstract && tr = Public then v else
+ set May_weak (mem May_neg v) v)
+ params required
let add_false = List.map (fun ty -> false, ty)
(* A parameter is constrained if either is is instantiated,
or it is a variable appearing in another parameter *)
let constrained env vars ty =
- let ty = Ctype.expand_head env ty in
match ty.desc with
| Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
| _ -> true
| Some ret_type ->
match Ctype.repr ret_type with
| {desc=Tconstr (path, tyl, _)} ->
+ (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+ let tyl = List.map Ctype.repr tyl in
let fvl = List.map Ctype.free_variables tyl in
let _ =
List.fold_left2
- (fun (fv1,fv2) ty (c,n) ->
+ (fun (fv1,fv2) ty (c,n,i) ->
match fv2 with [] -> assert false
| fv :: fv2 ->
(* fv1 @ fv2 = free_variables of other parameters *)
let compute_variance_decl env check decl (required, loc as rloc) =
if decl.type_kind = Type_abstract && decl.type_manifest = None then
- List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true))
+ List.map
+ (fun (c, n, i) ->
+ make (not n) (not c) (i (*|| decl.type_transparence = Type_new*)))
required
- else match decl.type_kind with
- | Type_abstract ->
- begin match decl.type_manifest with
- None -> assert false
- | Some ty -> compute_variance_type env check rloc decl [false, ty]
- end
+ else
+ let mn =
+ match decl.type_manifest with
+ None -> []
+ | Some ty -> [false, ty]
+ in
+ match decl.type_kind with
+ Type_abstract ->
+ compute_variance_type env check rloc decl mn
| Type_variant tll ->
if List.for_all (fun (_,_,ret) -> ret = None) tll then
compute_variance_type env check rloc decl
- (add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll)))
+ (mn @ add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll)))
else begin
+ let mn =
+ List.map (fun (_,ty) -> (Ident.create_persistent"",[ty],None)) mn in
+ let tll = mn @ tll in
match List.map (compute_variance_gadt env check rloc decl) tll with
- | vari :: _ -> vari
+ | vari :: rem ->
+ let varl = List.fold_left (List.map2 Variance.union) vari rem in
+ List.map
+ Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+ varl
| _ -> assert false
end
| Type_record (ftl, _) ->
compute_variance_type env check rloc decl
- (List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
+ (mn @ List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
let is_sharp id =
let s = Ident.name id in
new_decls required
in
let new_variances =
- List.map2
- (List.map2 (fun (c1,n1,t1) (c2,n2,t2) -> c1||c2, n1||n2, t1||t2))
- new_variances variances in
+ List.map2 (List.map2 Variance.union) new_variances variances in
if new_variances <> variances then
compute_variance_fixpoint env decls required new_variances
else begin
+ (* List.iter (fun (id, decl) ->
+ Printf.eprintf "%s:" (Ident.name id);
+ List.iter (fun (v : Variance.t) ->
+ Printf.eprintf " %x" (Obj.magic v : int))
+ decl.type_variance;
+ prerr_endline "")
+ new_decls; *)
List.iter2
(fun (id, decl) req -> if not (is_sharp id) then
ignore (compute_variance_decl new_env true decl req))
end
let init_variance (id, decl) =
- List.map (fun _ -> (false, false, false)) decl.type_params
+ List.map (fun _ -> Variance.null) decl.type_params
+
+let add_injectivity = List.map (fun (cn,cv) -> (cn,cv,false))
(* for typeclass.ml *)
let compute_variance_decls env cldecls =
let decls, required =
List.fold_right
(fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) ->
- (obj_id, obj_abbr) :: decls, (ci.ci_variance, ci.ci_loc) :: req)
+ (obj_id, obj_abbr) :: decls,
+ (add_injectivity ci.ci_variance, ci.ci_loc) :: req)
cldecls ([],[])
in
let variances = List.map init_variance decls in
let (decls, _) = compute_variance_fixpoint env decls required variances in
List.map2
(fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
- let variance = List.map (fun (c,n,t) -> (c,n)) decl.type_variance in
- (decl, {cl_abbr with type_variance = decl.type_variance},
+ let variance = decl.type_variance in
+ (decl, {cl_abbr with type_variance = variance},
{clty with cty_variance = variance},
{cltydef with clty_variance = variance}))
decls cldecls
Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
| None -> ())
name_sdecl_list tdecls;
- (* Check re-exportation *)
- List.iter2 (check_abbrev newenv) name_sdecl_list decls;
(* Check that constraints are enforced *)
List.iter2 (check_constraints newenv) name_sdecl_list decls;
(* Name recursion *)
in
(* Add variances to the environment *)
let required =
- List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc)
+ List.map
+ (fun (_, sdecl) -> add_injectivity sdecl.ptype_variance, sdecl.ptype_loc)
name_sdecl_list
in
let final_decls, final_env =
compute_variance_fixpoint env decls required (List.map init_variance decls)
in
+ (* Check re-exportation *)
+ List.iter2 (check_abbrev final_env) name_sdecl_list final_decls;
+ (* Keep original declaration *)
let final_decls = List.map2 (fun (id, name_loc, tdecl) (id2, decl) ->
(id, name_loc, { tdecl with typ_type = decl })
) tdecls final_decls in
(* Translate an exception rebinding *)
let transl_exn_rebind env loc lid =
- let (path, cdescr) =
+ let cdescr =
try
Env.lookup_constructor lid env
with Not_found ->
Ctype.unify env ty ty';
(cty, cty', loc)
with Ctype.Unify tr ->
- raise(Error(loc, Inconsistent_constraint tr)))
+ raise(Error(loc, Inconsistent_constraint (env, tr))))
sdecl.ptype_cstrs
in
let no_row = not (is_fixed_type sdecl) in
let cty = transl_simple_type env no_row sty in
Some cty, Some cty.ctyp_type
in
+ let priv =
+ if sdecl.ptype_private = Private then Private else
+ if arity_ok && orig_decl.type_kind <> Type_abstract
+ then orig_decl.type_private else sdecl.ptype_private
+ in
let decl =
{ type_params = params;
type_arity = List.length params;
type_kind = if arity_ok then orig_decl.type_kind else Type_abstract;
- type_private = sdecl.ptype_private;
+ type_private = priv;
type_manifest = man;
type_variance = [];
type_newtype_level = None;
let decl =
{decl with type_variance =
compute_variance_decl env false decl
- (sdecl.ptype_variance, sdecl.ptype_loc)} in
+ (add_injectivity sdecl.ptype_variance, sdecl.ptype_loc)} in
Ctype.end_def();
generalize_decl decl;
{
type_kind = Type_abstract;
type_private = Public;
type_manifest = None;
- type_variance = replicate_list (true, true, true) arity;
+ type_variance = replicate_list Variance.full arity;
type_newtype_level = None;
type_loc = Location.none;
} in
fprintf ppf
"@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
(Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
- | Inconsistent_constraint trace ->
+ | Inconsistent_constraint (env, trace) ->
fprintf ppf "The type constraints are not consistent.@.";
- Printtyp.report_unification_error ppf trace
+ Printtyp.report_unification_error ppf env trace
(fun ppf -> fprintf ppf "Type")
(fun ppf -> fprintf ppf "is not compatible with type")
- | Type_clash trace ->
- Printtyp.report_unification_error ppf trace
+ | Type_clash (env, trace) ->
+ Printtyp.report_unification_error ppf env trace
(function ppf ->
fprintf ppf "This type constructor expands to type")
(function ppf ->
fprintf ppf "The constructor@ %a@ is not an exception"
Printtyp.longident lid
| Bad_variance (n, v1, v2) ->
- let variance = function
- (true, true) -> "invariant"
- | (true, false) -> "covariant"
- | (false,true) -> "contravariant"
- | (false,false) -> "unrestricted"
+ let variance (p,n,i) =
+ let inj = if i then "injective " else "" in
+ match p, n with
+ true, true -> inj ^ "invariant"
+ | true, false -> inj ^ "covariant"
+ | false, true -> inj ^ "contravariant"
+ | false, false -> if inj = "" then "unrestricted" else inj
in
let suffix n =
let teen = (n mod 100)/10 = 1 in
| 3 when not teen -> "rd"
| _ -> "th"
in
- if n < 1 then
- fprintf ppf "@[%s@ %s@]"
+ if n = -1 then
+ fprintf ppf "@[%s@ %s@ It"
"In this definition, a type variable has a variance that"
"is not reflected by its occurrence in type parameters."
+ else if n = -2 then
+ fprintf ppf "@[%s@ %s@]"
+ "In this definition, a type variable cannot be deduced"
+ "from the type parameters."
+ else if n = -3 then
+ fprintf ppf "@[%s@ %s@ It"
+ "In this definition, a type variable has a variance that"
+ "cannot be deduced from the type parameters."
else
- fprintf ppf "@[%s@ %s@ %s %d%s %s %s,@ %s %s@]"
+ fprintf ppf "@[%s@ %s@ The %d%s type parameter"
"In this definition, expected parameter"
"variances are not satisfied."
- "The" n (suffix n)
- "type parameter was expected to be" (variance v2)
- "but it is" (variance v1)
+ n (suffix n);
+ if n <> -2 then
+ fprintf ppf " was expected to be %s,@ but it is %s.@]"
+ (variance v2) (variance v1)
| Unavailable_type_constructor p ->
fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
| Bad_fixed_type r ->
(* *)
(***********************************************************************)
-(* $Id: typedecl.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
(* Typing of type definitions and primitive definitions *)
open Asttypes
(Ident.t * type_declaration) list
val check_recmod_typedecl:
Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+ Env.t -> Location.t -> Ident.t -> type_declaration -> unit
(* for fixed types *)
val is_fixed_type : Parsetree.type_declaration -> bool
| Recursive_abbrev of string
| Definition_mismatch of type_expr * Includecore.type_mismatch list
| Constraint_failed of type_expr * type_expr
- | Inconsistent_constraint of (type_expr * type_expr) list
- | Type_clash of (type_expr * type_expr) list
+ | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
+ | Type_clash of Env.t * (type_expr * type_expr) list
| Parameters_differ of Path.t * type_expr * type_expr
| Null_arity_external
| Missing_native_external
| Unbound_type_var of type_expr * type_declaration
| Unbound_exception of Longident.t
| Not_an_exception of Longident.t
- | Bad_variance of int * (bool*bool) * (bool*bool)
+ | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool)
| Unavailable_type_constructor of Path.t
| Bad_fixed_type of string
| Unbound_type_var_exc of type_expr * type_expr
(* *)
(***********************************************************************)
-(* $Id: typedtree.ml 12681 2012-07-10 08:33:16Z garrigue $ *)
-
(* Abstract syntax tree after typing *)
open Misc
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
- Path.t * Longident.t loc * constructor_description * pattern list * bool
+ Longident.t loc * constructor_description * pattern list * bool
| Tpat_variant of label * pattern option * row_desc ref
| Tpat_record of
- (Path.t * Longident.t loc * label_description * pattern) list *
+ (Longident.t loc * label_description * pattern) list *
closed_flag
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
and exp_extra =
| Texp_constraint of core_type option * core_type option
- | Texp_open of Path.t * Longident.t loc * Env.t
+ | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
| Texp_poly of core_type option
| Texp_newtype of string
| Texp_try of expression * (pattern * expression) list
| Texp_tuple of expression list
| Texp_construct of
- Path.t * Longident.t loc * constructor_description * expression list *
+ Longident.t loc * constructor_description * expression list *
bool
| Texp_variant of label * expression option
| Texp_record of
- (Path.t * Longident.t loc * label_description * expression) list *
+ (Longident.t loc * label_description * expression) list *
expression option
- | Texp_field of expression * Path.t * Longident.t loc * label_description
+ | Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
- expression * Path.t * Longident.t loc * label_description * expression
+ expression * Longident.t loc * label_description * expression
| Texp_array of expression list
| Texp_ifthenelse of expression * expression * expression option
| Texp_sequence of expression * expression
| Tstr_module of Ident.t * string loc * module_expr
| Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
| Tstr_modtype of Ident.t * string loc * module_type
- | Tstr_open of Path.t * Longident.t loc
+ | Tstr_open of override_flag * Path.t * Longident.t loc
| Tstr_class of (class_declaration * string list * virtual_flag) list
| Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
- | Tstr_include of module_expr * Ident.t list
+ | Tstr_include of module_expr * Types.signature
and module_coercion =
Tcoerce_none
| Tsig_module of Ident.t * string loc * module_type
| Tsig_recmodule of (Ident.t * string loc * module_type) list
| Tsig_modtype of Ident.t * string loc * modtype_declaration
- | Tsig_open of Path.t * Longident.t loc
+ | Tsig_open of override_flag * Path.t * Longident.t loc
| Tsig_include of module_type * Types.signature
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
let iter_pattern_desc f = function
| Tpat_alias(p, _, _) -> f p
| Tpat_tuple patl -> List.iter f patl
- | Tpat_construct(_, _, cstr, patl, _) -> List.iter f patl
+ | Tpat_construct(_, cstr, patl, _) -> List.iter f patl
| Tpat_variant(_, pat, _) -> may f pat
| Tpat_record (lbl_pat_list, _) ->
- List.iter (fun (_, _, lbl, pat) -> f pat) lbl_pat_list
+ List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list
| Tpat_array patl -> List.iter f patl
| Tpat_or(p1, p2, _) -> f p1; f p2
| Tpat_lazy p -> f p
| Tpat_tuple pats ->
Tpat_tuple (List.map f pats)
| Tpat_record (lpats, closed) ->
- Tpat_record (List.map (fun ( lid, lid_loc, l,p) -> lid, lid_loc, l, f p)
- lpats, closed)
- | Tpat_construct (lid, lid_loc, c,pats, arity) ->
- Tpat_construct (lid, lid_loc, c, List.map f pats, arity)
+ Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
+ | Tpat_construct (lid, c,pats, arity) ->
+ Tpat_construct (lid, c, List.map f pats, arity)
| Tpat_array pats ->
Tpat_array (List.map f pats)
| Tpat_lazy p1 -> Tpat_lazy (f p1)
(* *)
(***********************************************************************)
-(* $Id: typedtree.mli 12681 2012-07-10 08:33:16Z garrigue $ *)
-
(* Abstract syntax tree after typing *)
open Asttypes
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
- Path.t * Longident.t loc * constructor_description * pattern list * bool
+ Longident.t loc * constructor_description * pattern list * bool
| Tpat_variant of label * pattern option * row_desc ref
| Tpat_record of
- (Path.t * Longident.t loc * label_description * pattern) list *
+ (Longident.t loc * label_description * pattern) list *
closed_flag
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
and exp_extra =
| Texp_constraint of core_type option * core_type option
- | Texp_open of Path.t * Longident.t loc * Env.t
+ | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
| Texp_poly of core_type option
| Texp_newtype of string
| Texp_try of expression * (pattern * expression) list
| Texp_tuple of expression list
| Texp_construct of
- Path.t * Longident.t loc * constructor_description * expression list *
+ Longident.t loc * constructor_description * expression list *
bool
| Texp_variant of label * expression option
| Texp_record of
- (Path.t * Longident.t loc * label_description * expression) list *
+ (Longident.t loc * label_description * expression) list *
expression option
- | Texp_field of expression * Path.t * Longident.t loc * label_description
+ | Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
- expression * Path.t * Longident.t loc * label_description * expression
+ expression * Longident.t loc * label_description * expression
| Texp_array of expression list
| Texp_ifthenelse of expression * expression * expression option
| Texp_sequence of expression * expression
| Tstr_module of Ident.t * string loc * module_expr
| Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
| Tstr_modtype of Ident.t * string loc * module_type
- | Tstr_open of Path.t * Longident.t loc
+ | Tstr_open of override_flag * Path.t * Longident.t loc
| Tstr_class of (class_declaration * string list * virtual_flag) list
| Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
- | Tstr_include of module_expr * Ident.t list
+ | Tstr_include of module_expr * Types.signature
and module_coercion =
Tcoerce_none
| Tsig_module of Ident.t * string loc * module_type
| Tsig_recmodule of (Ident.t * string loc * module_type) list
| Tsig_modtype of Ident.t * string loc * modtype_declaration
- | Tsig_open of Path.t * Longident.t loc
+ | Tsig_open of override_flag * Path.t * Longident.t loc
| Tsig_include of module_type * Types.signature
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
val let_bound_idents: (pattern * expression) list -> Ident.t list
val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
-val pat_bound_idents: pattern -> Ident.t list
val let_bound_idents_with_loc:
(pattern * expression) list -> (Ident.t * string loc) list
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(**************************************************************************)
+
+(*
+TODO:
+ - 2012/05/10: Follow camlp4 way of building map and iter using classes
+ and inheritance ?
+*)
+
+open Asttypes
+open Typedtree
+
+module type IteratorArgument = sig
+
+ val enter_structure : structure -> unit
+ val enter_value_description : value_description -> unit
+ val enter_type_declaration : type_declaration -> unit
+ val enter_exception_declaration :
+ exception_declaration -> unit
+ val enter_pattern : pattern -> unit
+ val enter_expression : expression -> unit
+ val enter_package_type : package_type -> unit
+ val enter_signature : signature -> unit
+ val enter_signature_item : signature_item -> unit
+ val enter_modtype_declaration : modtype_declaration -> unit
+ val enter_module_type : module_type -> unit
+ val enter_module_expr : module_expr -> unit
+ val enter_with_constraint : with_constraint -> unit
+ val enter_class_expr : class_expr -> unit
+ val enter_class_signature : class_signature -> unit
+ val enter_class_declaration : class_declaration -> unit
+ val enter_class_description : class_description -> unit
+ val enter_class_type_declaration : class_type_declaration -> unit
+ val enter_class_type : class_type -> unit
+ val enter_class_type_field : class_type_field -> unit
+ val enter_core_type : core_type -> unit
+ val enter_core_field_type : core_field_type -> unit
+ val enter_class_structure : class_structure -> unit
+ val enter_class_field : class_field -> unit
+ val enter_structure_item : structure_item -> unit
+
+
+ val leave_structure : structure -> unit
+ val leave_value_description : value_description -> unit
+ val leave_type_declaration : type_declaration -> unit
+ val leave_exception_declaration :
+ exception_declaration -> unit
+ val leave_pattern : pattern -> unit
+ val leave_expression : expression -> unit
+ val leave_package_type : package_type -> unit
+ val leave_signature : signature -> unit
+ val leave_signature_item : signature_item -> unit
+ val leave_modtype_declaration : modtype_declaration -> unit
+ val leave_module_type : module_type -> unit
+ val leave_module_expr : module_expr -> unit
+ val leave_with_constraint : with_constraint -> unit
+ val leave_class_expr : class_expr -> unit
+ val leave_class_signature : class_signature -> unit
+ val leave_class_declaration : class_declaration -> unit
+ val leave_class_description : class_description -> unit
+ val leave_class_type_declaration : class_type_declaration -> unit
+ val leave_class_type : class_type -> unit
+ val leave_class_type_field : class_type_field -> unit
+ val leave_core_type : core_type -> unit
+ val leave_core_field_type : core_field_type -> unit
+ val leave_class_structure : class_structure -> unit
+ val leave_class_field : class_field -> unit
+ val leave_structure_item : structure_item -> unit
+
+ val enter_bindings : rec_flag -> unit
+ val enter_binding : pattern -> expression -> unit
+ val leave_binding : pattern -> expression -> unit
+ val leave_bindings : rec_flag -> unit
+
+ end
+
+module MakeIterator(Iter : IteratorArgument) : sig
+
+ val iter_structure : structure -> unit
+ val iter_signature : signature -> unit
+ val iter_structure_item : structure_item -> unit
+ val iter_signature_item : signature_item -> unit
+ val iter_expression : expression -> unit
+ val iter_module_type : module_type -> unit
+ val iter_pattern : pattern -> unit
+ val iter_class_expr : class_expr -> unit
+
+ end = struct
+
+ let may_iter f v =
+ match v with
+ None -> ()
+ | Some x -> f x
+
+
+ open Asttypes
+
+ let rec iter_structure str =
+ Iter.enter_structure str;
+ List.iter iter_structure_item str.str_items;
+ Iter.leave_structure str
+
+
+ and iter_binding (pat, exp) =
+ Iter.enter_binding pat exp;
+ iter_pattern pat;
+ iter_expression exp;
+ Iter.leave_binding pat exp
+
+ and iter_bindings rec_flag list =
+ Iter.enter_bindings rec_flag;
+ List.iter iter_binding list;
+ Iter.leave_bindings rec_flag
+
+ and iter_structure_item item =
+ Iter.enter_structure_item item;
+ begin
+ match item.str_desc with
+ Tstr_eval exp -> iter_expression exp
+ | Tstr_value (rec_flag, list) ->
+ iter_bindings rec_flag list
+ | Tstr_primitive (id, _, v) -> iter_value_description v
+ | Tstr_type list ->
+ List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
+ | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
+ | Tstr_exn_rebind (id, _, p, _) -> ()
+ | Tstr_module (id, _, mexpr) ->
+ iter_module_expr mexpr
+ | Tstr_recmodule list ->
+ List.iter (fun (id, _, mtype, mexpr) ->
+ iter_module_type mtype;
+ iter_module_expr mexpr) list
+ | Tstr_modtype (id, _, mtype) ->
+ iter_module_type mtype
+ | Tstr_open _ -> ()
+ | Tstr_class list ->
+ List.iter (fun (ci, _, _) ->
+ Iter.enter_class_declaration ci;
+ iter_class_expr ci.ci_expr;
+ Iter.leave_class_declaration ci;
+ ) list
+ | Tstr_class_type list ->
+ List.iter (fun (id, _, ct) ->
+ Iter.enter_class_type_declaration ct;
+ iter_class_type ct.ci_expr;
+ Iter.leave_class_type_declaration ct;
+ ) list
+ | Tstr_include (mexpr, _) ->
+ iter_module_expr mexpr
+ end;
+ Iter.leave_structure_item item
+
+ and iter_value_description v =
+ Iter.enter_value_description v;
+ iter_core_type v.val_desc;
+ Iter.leave_value_description v
+
+ and iter_type_declaration decl =
+ Iter.enter_type_declaration decl;
+ List.iter (fun (ct1, ct2, loc) ->
+ iter_core_type ct1;
+ iter_core_type ct2
+ ) decl.typ_cstrs;
+ begin match decl.typ_kind with
+ Ttype_abstract -> ()
+ | Ttype_variant list ->
+ List.iter (fun (s, _, cts, loc) ->
+ List.iter iter_core_type cts
+ ) list
+ | Ttype_record list ->
+ List.iter (fun (s, _, mut, ct, loc) ->
+ iter_core_type ct
+ ) list
+ end;
+ begin match decl.typ_manifest with
+ None -> ()
+ | Some ct -> iter_core_type ct
+ end;
+ Iter.leave_type_declaration decl
+
+ and iter_exception_declaration decl =
+ Iter.enter_exception_declaration decl;
+ List.iter iter_core_type decl.exn_params;
+ Iter.leave_exception_declaration decl;
+
+ and iter_pattern pat =
+ Iter.enter_pattern pat;
+ List.iter (fun (cstr, _) -> match cstr with
+ | Tpat_type _ -> ()
+ | Tpat_unpack -> ()
+ | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
+ begin
+ match pat.pat_desc with
+ Tpat_any -> ()
+ | Tpat_var (id, _) -> ()
+ | Tpat_alias (pat1, _, _) -> iter_pattern pat1
+ | Tpat_constant cst -> ()
+ | Tpat_tuple list ->
+ List.iter iter_pattern list
+ | Tpat_construct (_, _, args, _) ->
+ List.iter iter_pattern args
+ | Tpat_variant (label, pato, _) ->
+ begin match pato with
+ None -> ()
+ | Some pat -> iter_pattern pat
+ end
+ | Tpat_record (list, closed) ->
+ List.iter (fun (_, _, pat) -> iter_pattern pat) list
+ | Tpat_array list -> List.iter iter_pattern list
+ | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
+ | Tpat_lazy p -> iter_pattern p
+ end;
+ Iter.leave_pattern pat
+
+ and option f x = match x with None -> () | Some e -> f e
+
+ and iter_expression exp =
+ Iter.enter_expression exp;
+ List.iter (function (cstr, _) ->
+ match cstr with
+ Texp_constraint (cty1, cty2) ->
+ option iter_core_type cty1; option iter_core_type cty2
+ | Texp_open (_, path, _, _) -> ()
+ | Texp_poly cto -> option iter_core_type cto
+ | Texp_newtype s -> ())
+ exp.exp_extra;
+ begin
+ match exp.exp_desc with
+ Texp_ident (path, _, _) -> ()
+ | Texp_constant cst -> ()
+ | Texp_let (rec_flag, list, exp) ->
+ iter_bindings rec_flag list;
+ iter_expression exp
+ | Texp_function (label, cases, _) ->
+ iter_bindings Nonrecursive cases
+ | Texp_apply (exp, list) ->
+ iter_expression exp;
+ List.iter (fun (label, expo, _) ->
+ match expo with
+ None -> ()
+ | Some exp -> iter_expression exp
+ ) list
+ | Texp_match (exp, list, _) ->
+ iter_expression exp;
+ iter_bindings Nonrecursive list
+ | Texp_try (exp, list) ->
+ iter_expression exp;
+ iter_bindings Nonrecursive list
+ | Texp_tuple list ->
+ List.iter iter_expression list
+ | Texp_construct (_, _, args, _) ->
+ List.iter iter_expression args
+ | Texp_variant (label, expo) ->
+ begin match expo with
+ None -> ()
+ | Some exp -> iter_expression exp
+ end
+ | Texp_record (list, expo) ->
+ List.iter (fun (_, _, exp) -> iter_expression exp) list;
+ begin match expo with
+ None -> ()
+ | Some exp -> iter_expression exp
+ end
+ | Texp_field (exp, _, label) ->
+ iter_expression exp
+ | Texp_setfield (exp1, _, label, exp2) ->
+ iter_expression exp1;
+ iter_expression exp2
+ | Texp_array list ->
+ List.iter iter_expression list
+ | Texp_ifthenelse (exp1, exp2, expo) ->
+ iter_expression exp1;
+ iter_expression exp2;
+ begin match expo with
+ None -> ()
+ | Some exp -> iter_expression exp
+ end
+ | Texp_sequence (exp1, exp2) ->
+ iter_expression exp1;
+ iter_expression exp2
+ | Texp_while (exp1, exp2) ->
+ iter_expression exp1;
+ iter_expression exp2
+ | Texp_for (id, _, exp1, exp2, dir, exp3) ->
+ iter_expression exp1;
+ iter_expression exp2;
+ iter_expression exp3
+ | Texp_when (exp1, exp2) ->
+ iter_expression exp1;
+ iter_expression exp2
+ | Texp_send (exp, meth, expo) ->
+ iter_expression exp;
+ begin
+ match expo with
+ None -> ()
+ | Some exp -> iter_expression exp
+ end
+ | Texp_new (path, _, _) -> ()
+ | Texp_instvar (_, path, _) -> ()
+ | Texp_setinstvar (_, _, _, exp) ->
+ iter_expression exp
+ | Texp_override (_, list) ->
+ List.iter (fun (path, _, exp) ->
+ iter_expression exp
+ ) list
+ | Texp_letmodule (id, _, mexpr, exp) ->
+ iter_module_expr mexpr;
+ iter_expression exp
+ | Texp_assert exp -> iter_expression exp
+ | Texp_assertfalse -> ()
+ | Texp_lazy exp -> iter_expression exp
+ | Texp_object (cl, _) ->
+ iter_class_structure cl
+ | Texp_pack (mexpr) ->
+ iter_module_expr mexpr
+ end;
+ Iter.leave_expression exp;
+
+ and iter_package_type pack =
+ Iter.enter_package_type pack;
+ List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields;
+ Iter.leave_package_type pack;
+
+ and iter_signature sg =
+ Iter.enter_signature sg;
+ List.iter iter_signature_item sg.sig_items;
+ Iter.leave_signature sg;
+
+ and iter_signature_item item =
+ Iter.enter_signature_item item;
+ begin
+ match item.sig_desc with
+ Tsig_value (id, _, v) ->
+ iter_value_description v
+ | Tsig_type list ->
+ List.iter (fun (id, _, decl) ->
+ iter_type_declaration decl
+ ) list
+ | Tsig_exception (id, _, decl) ->
+ iter_exception_declaration decl
+ | Tsig_module (id, _, mtype) ->
+ iter_module_type mtype
+ | Tsig_recmodule list ->
+ List.iter (fun (id, _, mtype) -> iter_module_type mtype) list
+ | Tsig_modtype (id, _, mdecl) ->
+ iter_modtype_declaration mdecl
+ | Tsig_open _ -> ()
+ | Tsig_include (mty,_) -> iter_module_type mty
+ | Tsig_class list ->
+ List.iter iter_class_description list
+ | Tsig_class_type list ->
+ List.iter iter_class_type_declaration list
+ end;
+ Iter.leave_signature_item item;
+
+ and iter_modtype_declaration mdecl =
+ Iter.enter_modtype_declaration mdecl;
+ begin
+ match mdecl with
+ Tmodtype_abstract -> ()
+ | Tmodtype_manifest mtype -> iter_module_type mtype
+ end;
+ Iter.leave_modtype_declaration mdecl;
+
+
+ and iter_class_description cd =
+ Iter.enter_class_description cd;
+ iter_class_type cd.ci_expr;
+ Iter.leave_class_description cd;
+
+ and iter_class_type_declaration cd =
+ Iter.enter_class_type_declaration cd;
+ iter_class_type cd.ci_expr;
+ Iter.leave_class_type_declaration cd;
+
+ and iter_module_type mty =
+ Iter.enter_module_type mty;
+ begin
+ match mty.mty_desc with
+ Tmty_ident (path, _) -> ()
+ | Tmty_signature sg -> iter_signature sg
+ | Tmty_functor (id, _, mtype1, mtype2) ->
+ iter_module_type mtype1; iter_module_type mtype2
+ | Tmty_with (mtype, list) ->
+ iter_module_type mtype;
+ List.iter (fun (path, _, withc) ->
+ iter_with_constraint withc
+ ) list
+ | Tmty_typeof mexpr ->
+ iter_module_expr mexpr
+ end;
+ Iter.leave_module_type mty;
+
+ and iter_with_constraint cstr =
+ Iter.enter_with_constraint cstr;
+ begin
+ match cstr with
+ Twith_type decl -> iter_type_declaration decl
+ | Twith_module _ -> ()
+ | Twith_typesubst decl -> iter_type_declaration decl
+ | Twith_modsubst _ -> ()
+ end;
+ Iter.leave_with_constraint cstr;
+
+ and iter_module_expr mexpr =
+ Iter.enter_module_expr mexpr;
+ begin
+ match mexpr.mod_desc with
+ Tmod_ident (p, _) -> ()
+ | Tmod_structure st -> iter_structure st
+ | Tmod_functor (id, _, mtype, mexpr) ->
+ iter_module_type mtype;
+ iter_module_expr mexpr
+ | Tmod_apply (mexp1, mexp2, _) ->
+ iter_module_expr mexp1;
+ iter_module_expr mexp2
+ | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
+ iter_module_expr mexpr
+ | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+ iter_module_expr mexpr;
+ iter_module_type mtype
+ | Tmod_unpack (exp, mty) ->
+ iter_expression exp
+(* iter_module_type mty *)
+ end;
+ Iter.leave_module_expr mexpr;
+
+ and iter_class_expr cexpr =
+ Iter.enter_class_expr cexpr;
+ begin
+ match cexpr.cl_desc with
+ | Tcl_constraint (cl, None, _, _, _ ) ->
+ iter_class_expr cl;
+ | Tcl_structure clstr -> iter_class_structure clstr
+ | Tcl_fun (label, pat, priv, cl, partial) ->
+ iter_pattern pat;
+ List.iter (fun (id, _, exp) -> iter_expression exp) priv;
+ iter_class_expr cl
+
+ | Tcl_apply (cl, args) ->
+ iter_class_expr cl;
+ List.iter (fun (label, expo, _) ->
+ match expo with
+ None -> ()
+ | Some exp -> iter_expression exp
+ ) args
+
+ | Tcl_let (rec_flat, bindings, ivars, cl) ->
+ iter_bindings rec_flat bindings;
+ List.iter (fun (id, _, exp) -> iter_expression exp) ivars;
+ iter_class_expr cl
+
+ | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+ iter_class_expr cl;
+ iter_class_type clty
+
+ | Tcl_ident (_, _, tyl) ->
+ List.iter iter_core_type tyl
+ end;
+ Iter.leave_class_expr cexpr;
+
+ and iter_class_type ct =
+ Iter.enter_class_type ct;
+ begin
+ match ct.cltyp_desc with
+ Tcty_signature csg -> iter_class_signature csg
+ | Tcty_constr (path, _, list) ->
+ List.iter iter_core_type list
+ | Tcty_fun (label, ct, cl) ->
+ iter_core_type ct;
+ iter_class_type cl
+ end;
+ Iter.leave_class_type ct;
+
+ and iter_class_signature cs =
+ Iter.enter_class_signature cs;
+ iter_core_type cs.csig_self;
+ List.iter iter_class_type_field cs.csig_fields;
+ Iter.leave_class_signature cs
+
+
+ and iter_class_type_field ctf =
+ Iter.enter_class_type_field ctf;
+ begin
+ match ctf.ctf_desc with
+ Tctf_inher ct -> iter_class_type ct
+ | Tctf_val (s, mut, virt, ct) ->
+ iter_core_type ct
+ | Tctf_virt (s, priv, ct) ->
+ iter_core_type ct
+ | Tctf_meth (s, priv, ct) ->
+ iter_core_type ct
+ | Tctf_cstr (ct1, ct2) ->
+ iter_core_type ct1;
+ iter_core_type ct2
+ end;
+ Iter.leave_class_type_field ctf
+
+ and iter_core_type ct =
+ Iter.enter_core_type ct;
+ begin
+ match ct.ctyp_desc with
+ Ttyp_any -> ()
+ | Ttyp_var s -> ()
+ | Ttyp_arrow (label, ct1, ct2) ->
+ iter_core_type ct1;
+ iter_core_type ct2
+ | Ttyp_tuple list -> List.iter iter_core_type list
+ | Ttyp_constr (path, _, list) ->
+ List.iter iter_core_type list
+ | Ttyp_object list ->
+ List.iter iter_core_field_type list
+ | Ttyp_class (path, _, list, labels) ->
+ List.iter iter_core_type list
+ | Ttyp_alias (ct, s) ->
+ iter_core_type ct
+ | Ttyp_variant (list, bool, labels) ->
+ List.iter iter_row_field list
+ | Ttyp_poly (list, ct) -> iter_core_type ct
+ | Ttyp_package pack -> iter_package_type pack
+ end;
+ Iter.leave_core_type ct;
+
+ and iter_core_field_type cft =
+ Iter.enter_core_field_type cft;
+ begin match cft.field_desc with
+ Tcfield_var -> ()
+ | Tcfield (s, ct) -> iter_core_type ct
+ end;
+ Iter.leave_core_field_type cft;
+
+ and iter_class_structure cs =
+ Iter.enter_class_structure cs;
+ iter_pattern cs.cstr_pat;
+ List.iter iter_class_field cs.cstr_fields;
+ Iter.leave_class_structure cs;
+
+
+ and iter_row_field rf =
+ match rf with
+ Ttag (label, bool, list) ->
+ List.iter iter_core_type list
+ | Tinherit ct -> iter_core_type ct
+
+ and iter_class_field cf =
+ Iter.enter_class_field cf;
+ begin
+ match cf.cf_desc with
+ Tcf_inher (ovf, cl, super, _vals, _meths) ->
+ iter_class_expr cl
+ | Tcf_constr (cty, cty') ->
+ iter_core_type cty;
+ iter_core_type cty'
+ | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
+ iter_core_type cty
+ | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
+ iter_expression exp
+ | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
+ iter_core_type cty
+ | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
+ iter_expression exp
+(* | Tcf_let (rec_flag, bindings, exps) ->
+ iter_bindings rec_flag bindings;
+ List.iter (fun (id, _, exp) -> iter_expression exp) exps; *)
+ | Tcf_init exp ->
+ iter_expression exp
+ end;
+ Iter.leave_class_field cf;
+
+ end
+
+module DefaultIteratorArgument = struct
+
+ let enter_structure _ = ()
+ let enter_value_description _ = ()
+ let enter_type_declaration _ = ()
+ let enter_exception_declaration _ = ()
+ let enter_pattern _ = ()
+ let enter_expression _ = ()
+ let enter_package_type _ = ()
+ let enter_signature _ = ()
+ let enter_signature_item _ = ()
+ let enter_modtype_declaration _ = ()
+ let enter_module_type _ = ()
+ let enter_module_expr _ = ()
+ let enter_with_constraint _ = ()
+ let enter_class_expr _ = ()
+ let enter_class_signature _ = ()
+ let enter_class_declaration _ = ()
+ let enter_class_description _ = ()
+ let enter_class_type_declaration _ = ()
+ let enter_class_type _ = ()
+ let enter_class_type_field _ = ()
+ let enter_core_type _ = ()
+ let enter_core_field_type _ = ()
+ let enter_class_structure _ = ()
+ let enter_class_field _ = ()
+ let enter_structure_item _ = ()
+
+
+ let leave_structure _ = ()
+ let leave_value_description _ = ()
+ let leave_type_declaration _ = ()
+ let leave_exception_declaration _ = ()
+ let leave_pattern _ = ()
+ let leave_expression _ = ()
+ let leave_package_type _ = ()
+ let leave_signature _ = ()
+ let leave_signature_item _ = ()
+ let leave_modtype_declaration _ = ()
+ let leave_module_type _ = ()
+ let leave_module_expr _ = ()
+ let leave_with_constraint _ = ()
+ let leave_class_expr _ = ()
+ let leave_class_signature _ = ()
+ let leave_class_declaration _ = ()
+ let leave_class_description _ = ()
+ let leave_class_type_declaration _ = ()
+ let leave_class_type _ = ()
+ let leave_class_type_field _ = ()
+ let leave_core_type _ = ()
+ let leave_core_field_type _ = ()
+ let leave_class_structure _ = ()
+ let leave_class_field _ = ()
+ let leave_structure_item _ = ()
+
+ let enter_binding _ _ = ()
+ let leave_binding _ _ = ()
+
+ let enter_bindings _ = ()
+ let leave_bindings _ = ()
+
+ end
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
+(* *)
+(* Copyright 2007 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+
+module type IteratorArgument = sig
+ val enter_structure : structure -> unit
+ val enter_value_description : value_description -> unit
+ val enter_type_declaration : type_declaration -> unit
+ val enter_exception_declaration :
+ exception_declaration -> unit
+ val enter_pattern : pattern -> unit
+ val enter_expression : expression -> unit
+ val enter_package_type : package_type -> unit
+ val enter_signature : signature -> unit
+ val enter_signature_item : signature_item -> unit
+ val enter_modtype_declaration : modtype_declaration -> unit
+ val enter_module_type : module_type -> unit
+ val enter_module_expr : module_expr -> unit
+ val enter_with_constraint : with_constraint -> unit
+ val enter_class_expr : class_expr -> unit
+ val enter_class_signature : class_signature -> unit
+ val enter_class_declaration : class_declaration -> unit
+ val enter_class_description : class_description -> unit
+ val enter_class_type_declaration : class_type_declaration -> unit
+ val enter_class_type : class_type -> unit
+ val enter_class_type_field : class_type_field -> unit
+ val enter_core_type : core_type -> unit
+ val enter_core_field_type : core_field_type -> unit
+ val enter_class_structure : class_structure -> unit
+ val enter_class_field : class_field -> unit
+ val enter_structure_item : structure_item -> unit
+
+
+ val leave_structure : structure -> unit
+ val leave_value_description : value_description -> unit
+ val leave_type_declaration : type_declaration -> unit
+ val leave_exception_declaration :
+ exception_declaration -> unit
+ val leave_pattern : pattern -> unit
+ val leave_expression : expression -> unit
+ val leave_package_type : package_type -> unit
+ val leave_signature : signature -> unit
+ val leave_signature_item : signature_item -> unit
+ val leave_modtype_declaration : modtype_declaration -> unit
+ val leave_module_type : module_type -> unit
+ val leave_module_expr : module_expr -> unit
+ val leave_with_constraint : with_constraint -> unit
+ val leave_class_expr : class_expr -> unit
+ val leave_class_signature : class_signature -> unit
+ val leave_class_declaration : class_declaration -> unit
+ val leave_class_description : class_description -> unit
+ val leave_class_type_declaration : class_type_declaration -> unit
+ val leave_class_type : class_type -> unit
+ val leave_class_type_field : class_type_field -> unit
+ val leave_core_type : core_type -> unit
+ val leave_core_field_type : core_field_type -> unit
+ val leave_class_structure : class_structure -> unit
+ val leave_class_field : class_field -> unit
+ val leave_structure_item : structure_item -> unit
+
+ val enter_bindings : rec_flag -> unit
+ val enter_binding : pattern -> expression -> unit
+ val leave_binding : pattern -> expression -> unit
+ val leave_bindings : rec_flag -> unit
+
+ end
+
+module MakeIterator :
+ functor
+ (Iter : IteratorArgument) ->
+ sig
+ val iter_structure : structure -> unit
+ val iter_signature : signature -> unit
+ val iter_structure_item : structure_item -> unit
+ val iter_signature_item : signature_item -> unit
+ val iter_expression : expression -> unit
+ val iter_module_type : module_type -> unit
+ val iter_pattern : pattern -> unit
+ val iter_class_expr : class_expr -> unit
+ end
+
+module DefaultIteratorArgument : IteratorArgument
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, INRIA Saclay *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Typedtree
+
+module type MapArgument = sig
+ val enter_structure : structure -> structure
+ val enter_value_description : value_description -> value_description
+ val enter_type_declaration : type_declaration -> type_declaration
+ val enter_exception_declaration :
+ exception_declaration -> exception_declaration
+ val enter_pattern : pattern -> pattern
+ val enter_expression : expression -> expression
+ val enter_package_type : package_type -> package_type
+ val enter_signature : signature -> signature
+ val enter_signature_item : signature_item -> signature_item
+ val enter_modtype_declaration : modtype_declaration -> modtype_declaration
+ val enter_module_type : module_type -> module_type
+ val enter_module_expr : module_expr -> module_expr
+ val enter_with_constraint : with_constraint -> with_constraint
+ val enter_class_expr : class_expr -> class_expr
+ val enter_class_signature : class_signature -> class_signature
+ val enter_class_description : class_description -> class_description
+ val enter_class_type_declaration :
+ class_type_declaration -> class_type_declaration
+ val enter_class_infos : 'a class_infos -> 'a class_infos
+ val enter_class_type : class_type -> class_type
+ val enter_class_type_field : class_type_field -> class_type_field
+ val enter_core_type : core_type -> core_type
+ val enter_core_field_type : core_field_type -> core_field_type
+ val enter_class_structure : class_structure -> class_structure
+ val enter_class_field : class_field -> class_field
+ val enter_structure_item : structure_item -> structure_item
+
+ val leave_structure : structure -> structure
+ val leave_value_description : value_description -> value_description
+ val leave_type_declaration : type_declaration -> type_declaration
+ val leave_exception_declaration :
+ exception_declaration -> exception_declaration
+ val leave_pattern : pattern -> pattern
+ val leave_expression : expression -> expression
+ val leave_package_type : package_type -> package_type
+ val leave_signature : signature -> signature
+ val leave_signature_item : signature_item -> signature_item
+ val leave_modtype_declaration : modtype_declaration -> modtype_declaration
+ val leave_module_type : module_type -> module_type
+ val leave_module_expr : module_expr -> module_expr
+ val leave_with_constraint : with_constraint -> with_constraint
+ val leave_class_expr : class_expr -> class_expr
+ val leave_class_signature : class_signature -> class_signature
+ val leave_class_description : class_description -> class_description
+ val leave_class_type_declaration :
+ class_type_declaration -> class_type_declaration
+ val leave_class_infos : 'a class_infos -> 'a class_infos
+ val leave_class_type : class_type -> class_type
+ val leave_class_type_field : class_type_field -> class_type_field
+ val leave_core_type : core_type -> core_type
+ val leave_core_field_type : core_field_type -> core_field_type
+ val leave_class_structure : class_structure -> class_structure
+ val leave_class_field : class_field -> class_field
+ val leave_structure_item : structure_item -> structure_item
+
+end
+
+
+module MakeMap(Map : MapArgument) = struct
+
+ let may_map f v =
+ match v with
+ None -> v
+ | Some x -> Some (f x)
+
+
+ open Misc
+ open Asttypes
+
+ let rec map_structure str =
+ let str = Map.enter_structure str in
+ let str_items = List.map map_structure_item str.str_items in
+ Map.leave_structure { str with str_items = str_items }
+
+ and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
+
+ and map_bindings rec_flag list =
+ List.map map_binding list
+
+ and map_structure_item item =
+ let item = Map.enter_structure_item item in
+ let str_desc =
+ match item.str_desc with
+ Tstr_eval exp -> Tstr_eval (map_expression exp)
+ | Tstr_value (rec_flag, list) ->
+ Tstr_value (rec_flag, map_bindings rec_flag list)
+ | Tstr_primitive (id, name, v) ->
+ Tstr_primitive (id, name, map_value_description v)
+ | Tstr_type list ->
+ Tstr_type (List.map (
+ fun (id, name, decl) ->
+ (id, name, map_type_declaration decl) ) list)
+ | Tstr_exception (id, name, decl) ->
+ Tstr_exception (id, name, map_exception_declaration decl)
+ | Tstr_exn_rebind (id, name, path, lid) ->
+ Tstr_exn_rebind (id, name, path, lid)
+ | Tstr_module (id, name, mexpr) ->
+ Tstr_module (id, name, map_module_expr mexpr)
+ | Tstr_recmodule list ->
+ let list =
+ List.map (fun (id, name, mtype, mexpr) ->
+ (id, name, map_module_type mtype, map_module_expr mexpr)
+ ) list
+ in
+ Tstr_recmodule list
+ | Tstr_modtype (id, name, mtype) ->
+ Tstr_modtype (id, name, map_module_type mtype)
+ | Tstr_open (ovf, path, lid) -> Tstr_open (ovf, path, lid)
+ | Tstr_class list ->
+ let list =
+ List.map (fun (ci, string_list, virtual_flag) ->
+ let ci = Map.enter_class_infos ci in
+ let ci_expr = map_class_expr ci.ci_expr in
+ (Map.leave_class_infos { ci with ci_expr = ci_expr},
+ string_list, virtual_flag)
+ ) list
+ in
+ Tstr_class list
+ | Tstr_class_type list ->
+ let list = List.map (fun (id, name, ct) ->
+ let ct = Map.enter_class_infos ct in
+ let ci_expr = map_class_type ct.ci_expr in
+ (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
+ ) list in
+ Tstr_class_type list
+ | Tstr_include (mexpr, sg) ->
+ Tstr_include (map_module_expr mexpr, sg)
+ in
+ Map.leave_structure_item { item with str_desc = str_desc}
+
+ and map_value_description v =
+ let v = Map.enter_value_description v in
+ let val_desc = map_core_type v.val_desc in
+ Map.leave_value_description { v with val_desc = val_desc }
+
+ and map_type_declaration decl =
+ let decl = Map.enter_type_declaration decl in
+ let typ_cstrs = List.map (fun (ct1, ct2, loc) ->
+ (map_core_type ct1,
+ map_core_type ct2,
+ loc)
+ ) decl.typ_cstrs in
+ let typ_kind = match decl.typ_kind with
+ Ttype_abstract -> Ttype_abstract
+ | Ttype_variant list ->
+ let list = List.map (fun (s, name, cts, loc) ->
+ (s, name, List.map map_core_type cts, loc)
+ ) list in
+ Ttype_variant list
+ | Ttype_record list ->
+ let list =
+ List.map (fun (s, name, mut, ct, loc) ->
+ (s, name, mut, map_core_type ct, loc)
+ ) list in
+ Ttype_record list
+ in
+ let typ_manifest =
+ match decl.typ_manifest with
+ None -> None
+ | Some ct -> Some (map_core_type ct)
+ in
+ Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs;
+ typ_kind = typ_kind; typ_manifest = typ_manifest }
+
+ and map_exception_declaration decl =
+ let decl = Map.enter_exception_declaration decl in
+ let exn_params = List.map map_core_type decl.exn_params in
+ let decl = { exn_params = exn_params;
+ exn_exn = decl.exn_exn;
+ exn_loc = decl.exn_loc } in
+ Map.leave_exception_declaration decl;
+
+ and map_pattern pat =
+ let pat = Map.enter_pattern pat in
+ let pat_desc =
+ match pat.pat_desc with
+ | Tpat_alias (pat1, p, text) ->
+ let pat1 = map_pattern pat1 in
+ Tpat_alias (pat1, p, text)
+ | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
+ | Tpat_construct (lid, cstr_decl, args, arity) ->
+ Tpat_construct (lid, cstr_decl,
+ List.map map_pattern args, arity)
+ | Tpat_variant (label, pato, rowo) ->
+ let pato = match pato with
+ None -> pato
+ | Some pat -> Some (map_pattern pat)
+ in
+ Tpat_variant (label, pato, rowo)
+ | Tpat_record (list, closed) ->
+ Tpat_record (List.map (fun (lid, lab_desc, pat) ->
+ (lid, lab_desc, map_pattern pat) ) list, closed)
+ | Tpat_array list -> Tpat_array (List.map map_pattern list)
+ | Tpat_or (p1, p2, rowo) ->
+ Tpat_or (map_pattern p1, map_pattern p2, rowo)
+ | Tpat_lazy p -> Tpat_lazy (map_pattern p)
+ | Tpat_constant _
+ | Tpat_any
+ | Tpat_var _ -> pat.pat_desc
+
+ in
+ let pat_extra = List.map map_pat_extra pat.pat_extra in
+ Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra }
+
+ and map_pat_extra pat_extra =
+ match pat_extra with
+ | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc)
+ | (Tpat_type _ | Tpat_unpack), _ -> pat_extra
+
+ and map_expression exp =
+ let exp = Map.enter_expression exp in
+ let exp_desc =
+ match exp.exp_desc with
+ Texp_ident (_, _, _)
+ | Texp_constant _ -> exp.exp_desc
+ | Texp_let (rec_flag, list, exp) ->
+ Texp_let (rec_flag,
+ map_bindings rec_flag list,
+ map_expression exp)
+ | Texp_function (label, cases, partial) ->
+ Texp_function (label, map_bindings Nonrecursive cases, partial)
+ | Texp_apply (exp, list) ->
+ Texp_apply (map_expression exp,
+ List.map (fun (label, expo, optional) ->
+ let expo =
+ match expo with
+ None -> expo
+ | Some exp -> Some (map_expression exp)
+ in
+ (label, expo, optional)
+ ) list )
+ | Texp_match (exp, list, partial) ->
+ Texp_match (
+ map_expression exp,
+ map_bindings Nonrecursive list,
+ partial
+ )
+ | Texp_try (exp, list) ->
+ Texp_try (
+ map_expression exp,
+ map_bindings Nonrecursive list
+ )
+ | Texp_tuple list ->
+ Texp_tuple (List.map map_expression list)
+ | Texp_construct (lid, cstr_desc, args, arity) ->
+ Texp_construct (lid, cstr_desc,
+ List.map map_expression args, arity )
+ | Texp_variant (label, expo) ->
+ let expo =match expo with
+ None -> expo
+ | Some exp -> Some (map_expression exp)
+ in
+ Texp_variant (label, expo)
+ | Texp_record (list, expo) ->
+ let list =
+ List.map (fun (lid, lab_desc, exp) ->
+ (lid, lab_desc, map_expression exp)
+ ) list in
+ let expo = match expo with
+ None -> expo
+ | Some exp -> Some (map_expression exp)
+ in
+ Texp_record (list, expo)
+ | Texp_field (exp, lid, label) ->
+ Texp_field (map_expression exp, lid, label)
+ | Texp_setfield (exp1, lid, label, exp2) ->
+ Texp_setfield (
+ map_expression exp1,
+ lid,
+ label,
+ map_expression exp2)
+ | Texp_array list ->
+ Texp_array (List.map map_expression list)
+ | Texp_ifthenelse (exp1, exp2, expo) ->
+ Texp_ifthenelse (
+ map_expression exp1,
+ map_expression exp2,
+ match expo with
+ None -> expo
+ | Some exp -> Some (map_expression exp)
+ )
+ | Texp_sequence (exp1, exp2) ->
+ Texp_sequence (
+ map_expression exp1,
+ map_expression exp2
+ )
+ | Texp_while (exp1, exp2) ->
+ Texp_while (
+ map_expression exp1,
+ map_expression exp2
+ )
+ | Texp_for (id, name, exp1, exp2, dir, exp3) ->
+ Texp_for (
+ id, name,
+ map_expression exp1,
+ map_expression exp2,
+ dir,
+ map_expression exp3
+ )
+ | Texp_when (exp1, exp2) ->
+ Texp_when (
+ map_expression exp1,
+ map_expression exp2
+ )
+ | Texp_send (exp, meth, expo) ->
+ Texp_send (map_expression exp, meth, may_map map_expression expo)
+ | Texp_new (path, lid, cl_decl) -> exp.exp_desc
+ | Texp_instvar (_, path, _) -> exp.exp_desc
+ | Texp_setinstvar (path, lid, path2, exp) ->
+ Texp_setinstvar (path, lid, path2, map_expression exp)
+ | Texp_override (path, list) ->
+ Texp_override (
+ path,
+ List.map (fun (path, lid, exp) ->
+ (path, lid, map_expression exp)
+ ) list
+ )
+ | Texp_letmodule (id, name, mexpr, exp) ->
+ Texp_letmodule (
+ id, name,
+ map_module_expr mexpr,
+ map_expression exp
+ )
+ | Texp_assert exp -> Texp_assert (map_expression exp)
+ | Texp_assertfalse -> exp.exp_desc
+ | Texp_lazy exp -> Texp_lazy (map_expression exp)
+ | Texp_object (cl, string_list) ->
+ Texp_object (map_class_structure cl, string_list)
+ | Texp_pack (mexpr) ->
+ Texp_pack (map_module_expr mexpr)
+ in
+ let exp_extra = List.map map_exp_extra exp.exp_extra in
+ Map.leave_expression {
+ exp with
+ exp_desc = exp_desc;
+ exp_extra = exp_extra }
+
+ and map_exp_extra exp_extra =
+ let loc = snd exp_extra in
+ match fst exp_extra with
+ | Texp_constraint (Some ct, None) ->
+ Texp_constraint (Some (map_core_type ct), None), loc
+ | Texp_constraint (None, Some ct) ->
+ Texp_constraint (None, Some (map_core_type ct)), loc
+ | Texp_constraint (Some ct1, Some ct2) ->
+ Texp_constraint (Some (map_core_type ct1),
+ Some (map_core_type ct2)), loc
+ | Texp_poly (Some ct) ->
+ Texp_poly (Some ( map_core_type ct )), loc
+ | Texp_newtype _
+ | Texp_constraint (None, None)
+ | Texp_open _
+ | Texp_poly None -> exp_extra
+
+
+ and map_package_type pack =
+ let pack = Map.enter_package_type pack in
+ let pack_fields = List.map (
+ fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in
+ Map.leave_package_type { pack with pack_fields = pack_fields }
+
+ and map_signature sg =
+ let sg = Map.enter_signature sg in
+ let sig_items = List.map map_signature_item sg.sig_items in
+ Map.leave_signature { sg with sig_items = sig_items }
+
+ and map_signature_item item =
+ let item = Map.enter_signature_item item in
+ let sig_desc =
+ match item.sig_desc with
+ Tsig_value (id, name, v) ->
+ Tsig_value (id, name, map_value_description v)
+ | Tsig_type list -> Tsig_type (
+ List.map (fun (id, name, decl) ->
+ (id, name, map_type_declaration decl)
+ ) list
+ )
+ | Tsig_exception (id, name, decl) ->
+ Tsig_exception (id, name, map_exception_declaration decl)
+ | Tsig_module (id, name, mtype) ->
+ Tsig_module (id, name, map_module_type mtype)
+ | Tsig_recmodule list ->
+ Tsig_recmodule (List.map (
+ fun (id, name, mtype) ->
+ (id, name, map_module_type mtype) ) list)
+ | Tsig_modtype (id, name, mdecl) ->
+ Tsig_modtype (id, name, map_modtype_declaration mdecl)
+ | Tsig_open _ -> item.sig_desc
+ | Tsig_include (mty, sg) -> Tsig_include (map_module_type mty, sg)
+ | Tsig_class list -> Tsig_class (List.map map_class_description list)
+ | Tsig_class_type list ->
+ Tsig_class_type (List.map map_class_type_declaration list)
+ in
+ Map.leave_signature_item { item with sig_desc = sig_desc }
+
+ and map_modtype_declaration mdecl =
+ let mdecl = Map.enter_modtype_declaration mdecl in
+ let mdecl =
+ match mdecl with
+ Tmodtype_abstract -> Tmodtype_abstract
+ | Tmodtype_manifest mtype ->
+ Tmodtype_manifest (map_module_type mtype)
+ in
+ Map.leave_modtype_declaration mdecl
+
+
+ and map_class_description cd =
+ let cd = Map.enter_class_description cd in
+ let ci_expr = map_class_type cd.ci_expr in
+ Map.leave_class_description { cd with ci_expr = ci_expr}
+
+ and map_class_type_declaration cd =
+ let cd = Map.enter_class_type_declaration cd in
+ let ci_expr = map_class_type cd.ci_expr in
+ Map.leave_class_type_declaration { cd with ci_expr = ci_expr }
+
+ and map_module_type mty =
+ let mty = Map.enter_module_type mty in
+ let mty_desc =
+ match mty.mty_desc with
+ Tmty_ident (path, lid) -> mty.mty_desc
+ | Tmty_signature sg -> Tmty_signature (map_signature sg)
+ | Tmty_functor (id, name, mtype1, mtype2) ->
+ Tmty_functor (id, name, map_module_type mtype1,
+ map_module_type mtype2)
+ | Tmty_with (mtype, list) ->
+ Tmty_with (map_module_type mtype,
+ List.map (fun (path, lid, withc) ->
+ (path, lid, map_with_constraint withc)
+ ) list)
+ | Tmty_typeof mexpr ->
+ Tmty_typeof (map_module_expr mexpr)
+ in
+ Map.leave_module_type { mty with mty_desc = mty_desc}
+
+ and map_with_constraint cstr =
+ let cstr = Map.enter_with_constraint cstr in
+ let cstr =
+ match cstr with
+ Twith_type decl -> Twith_type (map_type_declaration decl)
+ | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
+ | Twith_module (path, lid) -> cstr
+ | Twith_modsubst (path, lid) -> cstr
+ in
+ Map.leave_with_constraint cstr
+
+ and map_module_expr mexpr =
+ let mexpr = Map.enter_module_expr mexpr in
+ let mod_desc =
+ match mexpr.mod_desc with
+ Tmod_ident (p, lid) -> mexpr.mod_desc
+ | Tmod_structure st -> Tmod_structure (map_structure st)
+ | Tmod_functor (id, name, mtype, mexpr) ->
+ Tmod_functor (id, name, map_module_type mtype,
+ map_module_expr mexpr)
+ | Tmod_apply (mexp1, mexp2, coercion) ->
+ Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)
+ | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) ->
+ Tmod_constraint (map_module_expr mexpr, mod_type,
+ Tmodtype_implicit, coercion)
+ | Tmod_constraint (mexpr, mod_type,
+ Tmodtype_explicit mtype, coercion) ->
+ Tmod_constraint (map_module_expr mexpr, mod_type,
+ Tmodtype_explicit (map_module_type mtype),
+ coercion)
+ | Tmod_unpack (exp, mod_type) ->
+ Tmod_unpack (map_expression exp, mod_type)
+ in
+ Map.leave_module_expr { mexpr with mod_desc = mod_desc }
+
+ and map_class_expr cexpr =
+ let cexpr = Map.enter_class_expr cexpr in
+ let cl_desc =
+ match cexpr.cl_desc with
+ | Tcl_constraint (cl, None, string_list1, string_list2, concr ) ->
+ Tcl_constraint (map_class_expr cl, None, string_list1,
+ string_list2, concr)
+ | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr)
+ | Tcl_fun (label, pat, priv, cl, partial) ->
+ Tcl_fun (label, map_pattern pat,
+ List.map (fun (id, name, exp) ->
+ (id, name, map_expression exp)) priv,
+ map_class_expr cl, partial)
+
+ | Tcl_apply (cl, args) ->
+ Tcl_apply (map_class_expr cl,
+ List.map (fun (label, expo, optional) ->
+ (label, may_map map_expression expo,
+ optional)
+ ) args)
+ | Tcl_let (rec_flat, bindings, ivars, cl) ->
+ Tcl_let (rec_flat, map_bindings rec_flat bindings,
+ List.map (fun (id, name, exp) ->
+ (id, name, map_expression exp)) ivars,
+ map_class_expr cl)
+
+ | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+ Tcl_constraint ( map_class_expr cl,
+ Some (map_class_type clty), vals, meths, concrs)
+
+ | Tcl_ident (id, name, tyl) ->
+ Tcl_ident (id, name, List.map map_core_type tyl)
+ in
+ Map.leave_class_expr { cexpr with cl_desc = cl_desc }
+
+ and map_class_type ct =
+ let ct = Map.enter_class_type ct in
+ let cltyp_desc =
+ match ct.cltyp_desc with
+ Tcty_signature csg -> Tcty_signature (map_class_signature csg)
+ | Tcty_constr (path, lid, list) ->
+ Tcty_constr (path, lid, List.map map_core_type list)
+ | Tcty_fun (label, ct, cl) ->
+ Tcty_fun (label, map_core_type ct, map_class_type cl)
+ in
+ Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
+
+ and map_class_signature cs =
+ let cs = Map.enter_class_signature cs in
+ let csig_self = map_core_type cs.csig_self in
+ let csig_fields = List.map map_class_type_field cs.csig_fields in
+ Map.leave_class_signature { cs with
+ csig_self = csig_self; csig_fields = csig_fields }
+
+
+ and map_class_type_field ctf =
+ let ctf = Map.enter_class_type_field ctf in
+ let ctf_desc =
+ match ctf.ctf_desc with
+ Tctf_inher ct -> Tctf_inher (map_class_type ct)
+ | Tctf_val (s, mut, virt, ct) ->
+ Tctf_val (s, mut, virt, map_core_type ct)
+ | Tctf_virt (s, priv, ct) ->
+ Tctf_virt (s, priv, map_core_type ct)
+ | Tctf_meth (s, priv, ct) ->
+ Tctf_meth (s, priv, map_core_type ct)
+ | Tctf_cstr (ct1, ct2) ->
+ Tctf_cstr (map_core_type ct1, map_core_type ct2)
+ in
+ Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
+
+ and map_core_type ct =
+ let ct = Map.enter_core_type ct in
+ let ctyp_desc =
+ match ct.ctyp_desc with
+ Ttyp_any
+ | Ttyp_var _ -> ct.ctyp_desc
+ | Ttyp_arrow (label, ct1, ct2) ->
+ Ttyp_arrow (label, map_core_type ct1, map_core_type ct2)
+ | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list)
+ | Ttyp_constr (path, lid, list) ->
+ Ttyp_constr (path, lid, List.map map_core_type list)
+ | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list)
+ | Ttyp_class (path, lid, list, labels) ->
+ Ttyp_class (path, lid, List.map map_core_type list, labels)
+ | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
+ | Ttyp_variant (list, bool, labels) ->
+ Ttyp_variant (List.map map_row_field list, bool, labels)
+ | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct)
+ | Ttyp_package pack -> Ttyp_package (map_package_type pack)
+ in
+ Map.leave_core_type { ct with ctyp_desc = ctyp_desc }
+
+ and map_core_field_type cft =
+ let cft = Map.enter_core_field_type cft in
+ let field_desc = match cft.field_desc with
+ Tcfield_var -> Tcfield_var
+ | Tcfield (s, ct) -> Tcfield (s, map_core_type ct)
+ in
+ Map.leave_core_field_type { cft with field_desc = field_desc }
+
+ and map_class_structure cs =
+ let cs = Map.enter_class_structure cs in
+ let cstr_pat = map_pattern cs.cstr_pat in
+ let cstr_fields = List.map map_class_field cs.cstr_fields in
+ Map.leave_class_structure { cs with cstr_pat = cstr_pat;
+ cstr_fields = cstr_fields }
+
+ and map_row_field rf =
+ match rf with
+ Ttag (label, bool, list) ->
+ Ttag (label, bool, List.map map_core_type list)
+ | Tinherit ct -> Tinherit (map_core_type ct)
+
+ and map_class_field cf =
+ let cf = Map.enter_class_field cf in
+ let cf_desc =
+ match cf.cf_desc with
+ Tcf_inher (ovf, cl, super, vals, meths) ->
+ Tcf_inher (ovf, map_class_expr cl, super, vals, meths)
+ | Tcf_constr (cty, cty') ->
+ Tcf_constr (map_core_type cty, map_core_type cty')
+ | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) ->
+ Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty),
+ override)
+ | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) ->
+ Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp),
+ override)
+ | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
+ Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty),
+ override)
+ | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
+ Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp),
+ override)
+ | Tcf_init exp -> Tcf_init (map_expression exp)
+ in
+ Map.leave_class_field { cf with cf_desc = cf_desc }
+end
+
+
+module DefaultMapArgument = struct
+
+ let enter_structure t = t
+ let enter_value_description t = t
+ let enter_type_declaration t = t
+ let enter_exception_declaration t = t
+ let enter_pattern t = t
+ let enter_expression t = t
+ let enter_package_type t = t
+ let enter_signature t = t
+ let enter_signature_item t = t
+ let enter_modtype_declaration t = t
+ let enter_module_type t = t
+ let enter_module_expr t = t
+ let enter_with_constraint t = t
+ let enter_class_expr t = t
+ let enter_class_signature t = t
+ let enter_class_description t = t
+ let enter_class_type_declaration t = t
+ let enter_class_infos t = t
+ let enter_class_type t = t
+ let enter_class_type_field t = t
+ let enter_core_type t = t
+ let enter_core_field_type t = t
+ let enter_class_structure t = t
+ let enter_class_field t = t
+ let enter_structure_item t = t
+
+
+ let leave_structure t = t
+ let leave_value_description t = t
+ let leave_type_declaration t = t
+ let leave_exception_declaration t = t
+ let leave_pattern t = t
+ let leave_expression t = t
+ let leave_package_type t = t
+ let leave_signature t = t
+ let leave_signature_item t = t
+ let leave_modtype_declaration t = t
+ let leave_module_type t = t
+ let leave_module_expr t = t
+ let leave_with_constraint t = t
+ let leave_class_expr t = t
+ let leave_class_signature t = t
+ let leave_class_description t = t
+ let leave_class_type_declaration t = t
+ let leave_class_infos t = t
+ let leave_class_type t = t
+ let leave_class_type_field t = t
+ let leave_core_type t = t
+ let leave_core_field_type t = t
+ let leave_class_structure t = t
+ let leave_class_field t = t
+ let leave_structure_item t = t
+
+end
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fabrice Le Fessant, INRIA Saclay *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Typedtree
+
+module type MapArgument = sig
+ val enter_structure : structure -> structure
+ val enter_value_description : value_description -> value_description
+ val enter_type_declaration : type_declaration -> type_declaration
+ val enter_exception_declaration :
+ exception_declaration -> exception_declaration
+ val enter_pattern : pattern -> pattern
+ val enter_expression : expression -> expression
+ val enter_package_type : package_type -> package_type
+ val enter_signature : signature -> signature
+ val enter_signature_item : signature_item -> signature_item
+ val enter_modtype_declaration : modtype_declaration -> modtype_declaration
+ val enter_module_type : module_type -> module_type
+ val enter_module_expr : module_expr -> module_expr
+ val enter_with_constraint : with_constraint -> with_constraint
+ val enter_class_expr : class_expr -> class_expr
+ val enter_class_signature : class_signature -> class_signature
+ val enter_class_description : class_description -> class_description
+ val enter_class_type_declaration :
+ class_type_declaration -> class_type_declaration
+ val enter_class_infos : 'a class_infos -> 'a class_infos
+ val enter_class_type : class_type -> class_type
+ val enter_class_type_field : class_type_field -> class_type_field
+ val enter_core_type : core_type -> core_type
+ val enter_core_field_type : core_field_type -> core_field_type
+ val enter_class_structure : class_structure -> class_structure
+ val enter_class_field : class_field -> class_field
+ val enter_structure_item : structure_item -> structure_item
+
+ val leave_structure : structure -> structure
+ val leave_value_description : value_description -> value_description
+ val leave_type_declaration : type_declaration -> type_declaration
+ val leave_exception_declaration :
+ exception_declaration -> exception_declaration
+ val leave_pattern : pattern -> pattern
+ val leave_expression : expression -> expression
+ val leave_package_type : package_type -> package_type
+ val leave_signature : signature -> signature
+ val leave_signature_item : signature_item -> signature_item
+ val leave_modtype_declaration : modtype_declaration -> modtype_declaration
+ val leave_module_type : module_type -> module_type
+ val leave_module_expr : module_expr -> module_expr
+ val leave_with_constraint : with_constraint -> with_constraint
+ val leave_class_expr : class_expr -> class_expr
+ val leave_class_signature : class_signature -> class_signature
+ val leave_class_description : class_description -> class_description
+ val leave_class_type_declaration :
+ class_type_declaration -> class_type_declaration
+ val leave_class_infos : 'a class_infos -> 'a class_infos
+ val leave_class_type : class_type -> class_type
+ val leave_class_type_field : class_type_field -> class_type_field
+ val leave_core_type : core_type -> core_type
+ val leave_core_field_type : core_field_type -> core_field_type
+ val leave_class_structure : class_structure -> class_structure
+ val leave_class_field : class_field -> class_field
+ val leave_structure_item : structure_item -> structure_item
+
+end
+
+module MakeMap :
+ functor
+ (Iter : MapArgument) ->
+sig
+ val map_structure : structure -> structure
+ val map_pattern : pattern -> pattern
+ val map_structure_item : structure_item -> structure_item
+ val map_expression : expression -> expression
+ val map_class_expr : class_expr -> class_expr
+
+ val map_signature : signature -> signature
+ val map_signature_item : signature_item -> signature_item
+ val map_module_type : module_type -> module_type
+end
+
+module DefaultMapArgument : MapArgument
(* *)
(***********************************************************************)
-(* $Id: typemod.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
open Misc
open Longident
open Path
| Incomplete_packed_module of type_expr
| Scoping_pack of Longident.t * type_expr
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
open Typedtree
let extract_sig env loc mty =
match Mtype.scrape env mty with
Mty_signature sg -> sg
- | _ -> raise(Error(loc, Signature_expected))
+ | _ -> raise(Error(loc, env, Signature_expected))
let extract_sig_open env loc mty =
match Mtype.scrape env mty with
Mty_signature sg -> sg
- | _ -> raise(Error(loc, Structure_expected mty))
+ | _ -> raise(Error(loc, env, Structure_expected mty))
(* Compute the environment after opening a module *)
-let type_open ?toplevel env loc lid =
+let type_open ?toplevel ovf env loc lid =
let (path, mty) = Typetexp.find_module env loc lid.txt in
let sg = extract_sig_open env loc mty in
- path, Env.open_signature ~loc ?toplevel path sg env
+ path, Env.open_signature ~loc ?toplevel ovf path sg env
(* Record a module type *)
let rm node =
add_rec_types (Env.add_type id decl env) rem
| _ -> env
-let check_type_decl env id row_id newdecl decl rs rem =
+let check_type_decl env loc id row_id newdecl decl rs rem =
let env = Env.add_type id newdecl env in
let env =
match row_id with None -> env | Some id -> Env.add_type id newdecl env in
let env = if rs = Trec_not then env else add_rec_types env rem in
- Includemod.type_declarations env id newdecl decl
+ Includemod.type_declarations env id newdecl decl;
+ Typedecl.check_coherence env loc id newdecl
let rec make_params n = function
[] -> []
Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env
}
+let make p n i =
+ let open Variance in
+ set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
let merge_constraint initial_env loc sg lid constr =
let real_id = ref None in
let rec merge env sg namelist row_id =
match (sg, namelist, constr) with
([], _, _) ->
- raise(Error(loc, With_no_component lid.txt))
+ raise(Error(loc, env, With_no_component lid.txt))
| (Sig_type(id, decl, rs) :: rem, [s],
Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
type_private = Private;
type_manifest = None;
type_variance =
- List.map (fun (c,n) -> (not n, not c, not c))
+ List.map (fun (c,n) -> make (not n) (not c) false)
sdecl.ptype_variance;
- type_loc = Location.none;
+ type_loc = sdecl.ptype_loc;
type_newtype_level = None }
and id_row = Ident.create (s^"#row") in
let initial_env = Env.add_type id_row decl_row initial_env in
let tdecl = Typedecl.transl_with_constraint
initial_env id (Some(Pident id_row)) decl sdecl in
let newdecl = tdecl.typ_type in
- check_type_decl env id row_id newdecl decl rs rem;
+ check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
let decl_row = {decl_row with type_params = newdecl.type_params} in
let rs' = if rs = Trec_first then Trec_not else rs in
(Pident id, lid, Twith_type tdecl),
let tdecl =
Typedecl.transl_with_constraint initial_env id None decl sdecl in
let newdecl = tdecl.typ_type in
- check_type_decl env id row_id newdecl decl rs rem;
+ check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
(Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem
| (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
when Ident.name id = s ^ "#row" ->
let tdecl =
Typedecl.transl_with_constraint initial_env id None decl sdecl in
let newdecl = tdecl.typ_type in
- check_type_decl env id row_id newdecl decl rs rem;
+ check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
real_id := Some id;
(Pident id, lid, Twith_typesubst tdecl),
make_next_first rs rem
) params sdecl.ptype_params;
lid
| _ -> raise Exit
- with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr))
+ with Exit ->
+ raise(Error(sdecl.ptype_loc, initial_env, With_need_typeconstr))
in
let (path, _) =
try Env.lookup_type lid.txt initial_env with Not_found -> assert false
in
(tcstr, sg)
with Includemod.Error explanation ->
- raise(Error(loc, With_mismatch(lid.txt, explanation)))
+ raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))
(* Add recursion flags on declarations arising from a mutually recursive
block. *)
| [] -> rem
| d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+let map_rec' = map_rec
+(*
let rec map_rec' fn decls rem =
match decls with
| (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
fn Trec_not d1 :: map_rec' fn dl rem
| _ -> map_rec fn decls rem
+*)
let rec map_rec'' fn decls rem =
match decls with
let info = approx_modtype_info env sinfo in
let (id, newenv) = Env.enter_modtype name.txt info env in
Sig_modtype(id, info) :: approx_sig newenv srem
- | Psig_open lid ->
- let (path, mty) = type_open env item.psig_loc lid in
+ | Psig_open (ovf, lid) ->
+ let (path, mty) = type_open ovf env item.psig_loc lid in
approx_sig mty srem
| Psig_include smty ->
let mty = approx_modtype env smty in
(* Auxiliaries for checking uniqueness of names in signatures and structures *)
-module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringSet =
+ Set.Make(struct type t = string let compare (x:t) y = compare x y end)
let check cl loc set_ref name =
if StringSet.mem name !set_ref
- then raise(Error(loc, Repeated_name(cl, name)))
+ then raise(Error(loc, Env.empty, Repeated_name(cl, name)))
else set_ref := StringSet.add name !set_ref
let check_sig_item type_names module_names modtype_names loc = function
check "module type" loc modtype_names (Ident.name id)
| _ -> ()
-let rec remove_values ids = function
+let rec remove_duplicates val_ids exn_ids = function
[] -> []
| Sig_value (id, _) :: rem
- when List.exists (Ident.equal id) ids -> remove_values ids rem
- | f :: rem -> f :: remove_values ids rem
+ when List.exists (Ident.equal id) val_ids ->
+ remove_duplicates val_ids exn_ids rem
+ | Sig_exception(id, _) :: rem
+ when List.exists (Ident.equal id) exn_ids ->
+ remove_duplicates val_ids exn_ids rem
+ | f :: rem -> f :: remove_duplicates val_ids exn_ids rem
let rec get_values = function
[] -> []
| Sig_value (id, _) :: rem -> id :: get_values rem
| f :: rem -> get_values rem
+let rec get_exceptions = function
+ [] -> []
+ | Sig_exception (id, _) :: rem -> id :: get_exceptions rem
+ | f :: rem -> get_exceptions rem
+
+
(* Check and translate a module type expression *)
let transl_modtype_longident loc env lid =
let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_exception (id, name, arg)) env loc :: trem,
- Sig_exception(id, arg.exn_exn) :: rem,
+ (if List.exists (Ident.equal id) (get_exceptions rem) then rem
+ else Sig_exception(id, arg.exn_exn) :: rem),
final_env
| Psig_module(name, smty) ->
check "module" item.psig_loc module_names name.txt;
mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem,
Sig_modtype(id, info) :: rem,
final_env
- | Psig_open lid ->
- let (path, newenv) = type_open env item.psig_loc lid in
+ | Psig_open (ovf, lid) ->
+ let (path, newenv) = type_open ovf env item.psig_loc lid in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env
+ mksig (Tsig_open (ovf, path,lid)) env loc :: trem,
+ rem, final_env
| Psig_include smty ->
let tmty = transl_modtype env smty in
let mty = tmty.mty_type in
let newenv = Env.add_signature sg env in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_include (tmty, sg)) env loc :: trem,
- remove_values (get_values rem) sg @ rem, final_env
+ remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem,
+ final_env
| Psig_class cl ->
List.iter
(fun {pci_name = name} ->
List.map2
(fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
sdecls curr in
+ let ids = List.map (fun (name, _) -> Ident.create name.txt) sdecls in
+ let approx_env =
+ (*
+ cf #5965
+ We use a dummy module type in order to detect a reference to one
+ of the module being defined during the call to approx_modtype.
+ It will be detected in Env.lookup_module.
+ *)
+ List.fold_left
+ (fun env id ->
+ let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in
+ Env.add_module id dummy env
+ )
+ env ids
+ in
let init =
- List.map
- (fun (name, smty) ->
- (Ident.create name.txt, name, approx_modtype env smty))
- sdecls in
+ List.map2
+ (fun id (name, smty) ->
+ (id, name, approx_modtype approx_env smty))
+ ids sdecls
+ in
let env0 = make_env init in
let dcl1 = transition env0 init in
let env1 = make_env2 dcl1 in
List.iter
(fun (pat, exp) ->
if not (Ctype.closed_schema exp.exp_type) then
- raise(Error(exp.exp_loc, Non_generalizable exp.exp_type)))
+ raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type)))
pat_exp_list
| Tstr_module(id, _, md) ->
if not (closed_modtype md.mod_type) then
- raise(Error(md.mod_loc, Non_generalizable_module md.mod_type))
+ raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type))
| _ -> ()
let check_nongen_schemes env str =
List.iter (check_nongen_scheme env) str
-(* Extract the list of "value" identifiers bound by a signature.
- "Value" identifiers are identifiers for signature components that
- correspond to a run-time value: values, exceptions, modules, classes.
- Note: manifest primitives do not correspond to a run-time value! *)
-
-let rec bound_value_identifiers = function
- [] -> []
- | Sig_value(id, {val_kind = Val_reg}) :: rem ->
- id :: bound_value_identifiers rem
- | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
- | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
- | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
- | _ :: rem -> bound_value_identifiers rem
-
(* Helpers for typing recursive modules *)
let anchor_submodule name anchor =
try
Includemod.modtypes env mty_actual' mty_decl'
with Includemod.Error msg ->
- raise(Error(modl.mod_loc, Not_included msg)) in
+ raise(Error(modl.mod_loc, env, Not_included msg)) in
let modl' =
{ mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
Tmodtype_explicit mty_decl, coercion);
(List.combine (List.map Longident.flatten nl) tl)
| _ ->
if nl = [] then Mty_ident p
- else raise(Error(loc, Signature_expected))
+ else raise(Error(loc, env, Signature_expected))
with Not_found ->
- raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p)))
+ let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in
+ raise(Typetexp.Error(loc, env, error))
let wrap_constraint env arg mty explicit =
let coercion =
try
Includemod.modtypes env arg.mod_type mty
with Includemod.Error msg ->
- raise(Error(arg.mod_loc, Not_included msg)) in
+ raise(Error(arg.mod_loc, env, Not_included msg)) in
{ mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
mod_type = mty;
mod_env = env;
(* Type a module value expression *)
-let mkstr desc loc env =
- let str = { str_desc = desc; str_loc = loc; str_env = env } in
- Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str);
- str
-
let rec type_module sttn funct_body anchor env smod =
match smod.pmod_desc with
Pmod_ident lid ->
try
Includemod.modtypes env arg.mod_type mty_param
with Includemod.Error msg ->
- raise(Error(sarg.pmod_loc, Not_included msg)) in
+ raise(Error(sarg.pmod_loc, env, Not_included msg)) in
let mty_appl =
match path with
Some path ->
Mtype.nondep_supertype
(Env.add_module param arg.mod_type env) param mty_res
with Not_found ->
- raise(Error(smod.pmod_loc,
+ raise(Error(smod.pmod_loc, env,
Cannot_eliminate_dependency mty_functor))
in
rm { mod_desc = Tmod_apply(funct, arg, coercion);
mod_env = env;
mod_loc = smod.pmod_loc }
| _ ->
- raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
+ raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
end
| Pmod_constraint(sarg, smty) ->
let arg = type_module true funct_body anchor env sarg in
| Pmod_unpack sexp ->
if funct_body then
- raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
+ raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
if !Clflags.principal then Ctype.begin_def ();
let exp = Typecore.type_exp env sexp in
if !Clflags.principal then begin
match Ctype.expand_head env exp.exp_type with
{desc = Tpackage (p, nl, tl)} ->
if List.exists (fun t -> Ctype.free_variables t <> []) tl then
- raise (Error (smod.pmod_loc,
+ raise (Error (smod.pmod_loc, env,
Incomplete_packed_module exp.exp_type));
if !Clflags.principal &&
not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
modtype_of_package env smod.pmod_loc p nl tl
| {desc = Tvar _} ->
raise (Typecore.Error
- (smod.pmod_loc, Typecore.Cannot_infer_signature))
+ (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
| _ ->
- raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type))
+ raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
in
rm { mod_desc = Tmod_unpack(exp, mty);
mod_type = mty;
and module_names = ref StringSet.empty
and modtype_names = ref StringSet.empty in
let rec type_struct env sstr =
- let mkstr desc loc = mkstr desc loc env in
+ let previous_saved_types = Cmt_format.get_saved_types () in
Ctype.init_def(Ident.current_time());
match sstr with
[] ->
([], [], env)
| pstr :: srem ->
let loc = pstr.pstr_loc in
+ let mk desc =
+ let str = { str_desc = desc; str_loc = loc; str_env = env } in
+ Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+ :: previous_saved_types);
+ str
+ in
match pstr.pstr_desc with
| Pstr_eval sexpr ->
let expr = Typecore.type_expression env sexpr in
+ let item = mk (Tstr_eval expr) in
let (str_rem, sig_rem, final_env) = type_struct env srem in
- (mkstr (Tstr_eval expr) loc :: str_rem, sig_rem, final_env)
+ (item :: str_rem, sig_rem, final_env)
| Pstr_value(rec_flag, sdefs) ->
let scope =
match rec_flag with
in
let (defs, newenv) =
Typecore.type_binding env rec_flag sdefs scope in
+ let item = mk (Tstr_value(rec_flag, defs)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
let bound_idents = let_bound_idents defs in
(* Note: Env.find_value does not trigger the value_used event. Values
will be marked as being used during the signature inclusion test. *)
let make_sig_value id =
Sig_value(id, Env.find_value (Pident id) newenv) in
- (mkstr (Tstr_value(rec_flag, defs)) loc :: str_rem,
+ (item :: str_rem,
map_end make_sig_value bound_idents sig_rem,
final_env)
| Pstr_primitive(name, sdesc) ->
let desc = Typedecl.transl_value_decl env loc sdesc in
let (id, newenv) = Env.enter_value name.txt desc.val_val env
~check:(fun s -> Warnings.Unused_value_declaration s) in
+ let item = mk (Tstr_primitive(id, name, desc)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_primitive(id, name, desc)) loc :: str_rem,
- Sig_value(id, desc.val_val) :: sig_rem,
- final_env)
+ (item :: str_rem, Sig_value(id, desc.val_val) :: sig_rem, final_env)
| Pstr_type sdecls ->
List.iter
(fun (name, decl) -> check "type" loc type_names name.txt)
sdecls;
let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
+ let item = mk (Tstr_type decls) in
let newenv' =
enrich_type_decls anchor decls env newenv in
let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
- (mkstr (Tstr_type decls) loc :: str_rem,
+ (item :: str_rem,
map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs))
decls sig_rem,
final_env)
| Pstr_exception(name, sarg) ->
let arg = Typedecl.transl_exception env loc sarg in
let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in
+ let item = mk (Tstr_exception(id, name, arg)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_exception(id, name, arg)) loc :: str_rem,
+ (item :: str_rem,
Sig_exception(id, arg.exn_exn) :: sig_rem,
final_env)
| Pstr_exn_rebind(name, longid) ->
let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
let (id, newenv) = Env.enter_exception name.txt arg env in
+ let item = mk (Tstr_exn_rebind(id, name, path, longid)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_exn_rebind(id, name, path, longid)) loc :: str_rem,
+ (item :: str_rem,
Sig_exception(id, arg) :: sig_rem,
final_env)
| Pstr_module(name, smodl) ->
smodl in
let mty = enrich_module_type anchor name.txt modl.mod_type env in
let (id, newenv) = Env.enter_module name.txt mty env in
+ let item = mk (Tstr_module(id, name, modl)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_module(id, name, modl)) loc :: str_rem,
+ (item :: str_rem,
Sig_module(id, modl.mod_type, Trec_not) :: sig_rem,
final_env)
| Pstr_recmodule sbind ->
decls sbind in
let bindings2 =
check_recmodule_inclusion newenv bindings1 in
+ let item = mk (Tstr_recmodule bindings2) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_recmodule bindings2) loc :: str_rem,
+ (item :: str_rem,
map_rec (fun rs (id, _, _, modl) -> Sig_module(id, modl.mod_type, rs))
bindings2 sig_rem,
final_env)
let mty = transl_modtype env smty in
let (id, newenv) =
Env.enter_modtype name.txt (Modtype_manifest mty.mty_type) env in
+ let item = mk (Tstr_modtype(id, name, mty)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_modtype(id, name, mty)) loc :: str_rem,
+ (item :: str_rem,
Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem,
final_env)
- | Pstr_open (lid) ->
- let (path, newenv) = type_open ~toplevel env loc lid in
+ | Pstr_open (ovf, lid) ->
+ let (path, newenv) = type_open ovf ~toplevel env loc lid in
+ let item = mk (Tstr_open (ovf, path, lid)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (mkstr (Tstr_open (path, lid)) loc :: str_rem, sig_rem, final_env)
+ (item :: str_rem, sig_rem, final_env)
| Pstr_class cl ->
List.iter
(fun {pci_name = name} -> check "type" loc type_names name.txt)
cl;
let (classes, new_env) = Typeclass.class_declarations env cl in
- let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (mkstr (Tstr_class
- (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) ->
- let vf = if d.cty_new = None then Virtual else Concrete in
- (* (i, s, m, c, vf) *) (c, m, vf)) classes)) loc ::
+ let item =
+ mk
+ (Tstr_class
+ (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) ->
+ let vf = if d.cty_new = None then Virtual else Concrete in
+ (* (i, s, m, c, vf) *) (c, m, vf)) classes))
(* TODO: check with Jacques why this is here
Tstr_class_type
(List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
Tstr_type
(List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
*)
- str_rem,
+ in
+ let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+ (item :: str_rem,
List.flatten
(map_rec
(fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) ->
- [Sig_class(i, d, rs);
- Sig_class_type(i', d', rs);
- Sig_type(i'', d'', rs);
- Sig_type(i''', d''', rs)])
+ [Sig_class(i, d, rs);
+ Sig_class_type(i', d', rs);
+ Sig_type(i'', d'', rs);
+ Sig_type(i''', d''', rs)])
classes [sig_rem]),
final_env)
| Pstr_class_type cl ->
(fun {pci_name = name} -> check "type" loc type_names name.txt)
cl;
let (classes, new_env) = Typeclass.class_type_declarations env cl in
- let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (mkstr (Tstr_class_type
- (List.map (fun (i, i_loc, d, _, _, _, _, c) ->
- (i, i_loc, c)) classes)) loc ::
+ let item =
+ mk
+ (Tstr_class_type
+ (List.map (fun (i, i_loc, d, _, _, _, _, c) ->
+ (i, i_loc, c)) classes))
(* TODO: check with Jacques why this is here
Tstr_type
(List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
Tstr_type
(List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
- str_rem,
+ in
+ let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+ (item :: str_rem,
List.flatten
(map_rec
(fun rs (i, _, d, i', d', i'', d'', _) ->
List.iter
(check_sig_item type_names module_names modtype_names loc) sg;
let new_env = Env.add_signature sg env in
+ let item = mk (Tstr_include (modl, sg)) in
let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (mkstr (Tstr_include (modl, bound_value_identifiers sg)) loc :: str_rem,
+ (item :: str_rem,
sg @ sig_rem,
final_env)
in
(Cmt_format.Partial_structure str :: previous_saved_types);
str, sg, final_env
-let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none
+let type_toplevel_phrase env s =
+ type_structure ~toplevel:true false None env s Location.none
let type_module = type_module true false None
let type_structure = type_structure false None
let mty = simplify_modtype mty in
(* PR#5036: must not contain non-generalized type variables *)
if not (closed_modtype mty) then
- raise(Error(smod.pmod_loc, Non_generalizable_module mty));
+ raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
tmty, mty
(* For Typecore *)
List.iter2
(fun n ty ->
try Ctype.unify env ty (Ctype.newvar ())
- with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty))))
+ with Ctype.Unify _ ->
+ raise (Error(m.pmod_loc, env, Scoping_pack (n,ty))))
nl tl';
(wrap_constraint env modl mty Tmodtype_implicit, tl')
Cmt_format.set_saved_types [];
try
Typecore.reset_delayed_checks ();
- let (str, sg, finalenv) = type_structure initial_env ast Location.none in
+ let (str, sg, finalenv) =
+ type_structure initial_env ast (Location.in_file sourcefile) in
let simple_sg = simplify_signature sg in
if !Clflags.print_types then begin
- fprintf std_formatter "%a@." Printtyp.signature simple_sg;
+ Printtyp.wrap_printing_env initial_env
+ (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
end else begin
let sourceintf =
try
find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
with Not_found ->
- raise(Error(Location.none, Interface_not_compiled sourceintf)) in
+ raise(Error(Location.in_file sourcefile, Env.empty,
+ Interface_not_compiled sourceintf)) in
let dclsig = Env.read_signature modulename intf_file in
let coercion = Includemod.compunit sourcefile sg intf_file dclsig in
Typecore.force_delayed_checks ();
let sg = Env.read_signature modname (pref ^ ".cmi") in
if Filename.check_suffix f ".cmi" &&
not(Mtype.no_code_needed_sig Env.initial sg)
- then raise(Error(Location.none, Implementation_is_required f));
+ then raise(Error(Location.none, Env.empty,
+ Implementation_is_required f));
(modname, Env.read_signature modname (pref ^ ".cmi")))
objfiles in
(* Compute signature of packaged unit *)
let mlifile = prefix ^ !Config.interface_suffix in
if Sys.file_exists mlifile then begin
if not (Sys.file_exists cmifile) then begin
- raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile))
+ raise(Error(Location.in_file mlifile, Env.empty,
+ Interface_not_compiled mlifile))
end;
let dclsig = Env.read_signature modulename cmifile in
Cmt_format.save_cmt (prefix ^ ".cmt") modulename
"The type %a in this module cannot be exported.@ " longident lid;
fprintf ppf
"Its type contains local dependencies:@ %a" type_expr ty
+
+let report_error env ppf err =
+ Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
(* *)
(***********************************************************************)
-(* $Id: typemod.mli 12542 2012-06-01 14:06:31Z frisch $ *)
-
(* Type-checking of the module language *)
open Types
val package_units:
string list -> string -> string -> Typedtree.module_coercion
-val bound_value_identifiers : Types.signature_item list -> Ident.t list
-
type error =
Cannot_apply of module_type
| Not_included of Includemod.error list
| Incomplete_packed_module of type_expr
| Scoping_pack of Longident.t * type_expr
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit
(* *)
(***********************************************************************)
-(* $Id: types.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Representation of types and declarations *)
-open Misc
open Asttypes
(* Type expressions for the core language *)
(* Maps of methods and instance variables *)
-module OrderedString = struct type t = string let compare = compare end
+module OrderedString =
+ struct type t = string let compare (x:t) y = compare x y end
module Meths = Map.Make(OrderedString)
module Vars = Meths
(* Constructor descriptions *)
type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
+ { cstr_name: string; (* Constructor name *)
+ cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
Record_regular (* All fields are boxed / tagged *)
| Record_float (* All fields are floats *)
+(* Variance *)
+
+module Variance = struct
+ type t = int
+ type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+ let single = function
+ | May_pos -> 1
+ | May_neg -> 2
+ | May_weak -> 4
+ | Inj -> 8
+ | Pos -> 16
+ | Neg -> 32
+ | Inv -> 64
+ let union v1 v2 = v1 lor v2
+ let inter v1 v2 = v1 land v2
+ let subset v1 v2 = (v1 land v2 = v1)
+ let set x b v =
+ if b then v lor single x else v land (lnot (single x))
+ let mem x = subset (single x)
+ let null = 0
+ let may_inv = 7
+ let full = 127
+ let covariant = single May_pos lor single Pos lor single Inj
+ let swap f1 f2 v =
+ let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+ let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+ let get_upper v = (mem May_pos v, mem May_neg v)
+ let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+end
+
(* Type definitions *)
type type_declaration =
type_kind: type_kind;
type_private: private_flag;
type_manifest: type_expr option;
- type_variance: (bool * bool * bool) list;
- (* covariant, contravariant, weakly contravariant *)
+ type_variance: Variance.t list;
type_newtype_level: (int * int) option;
type_loc: Location.t }
(Ident.t * mutable_flag * type_expr) list * record_representation
| Type_variant of (Ident.t * type_expr list * type_expr option) list
+and type_transparence =
+ Type_public (* unrestricted expansion *)
+ | Type_new (* "new" type *)
+ | Type_private (* private type *)
+
type exception_declaration =
{ exn_args: type_expr list;
exn_loc: Location.t }
mutable cty_type: class_type;
cty_path: Path.t;
cty_new: type_expr option;
- cty_variance: (bool * bool) list }
+ cty_variance: Variance.t list }
type class_type_declaration =
{ clty_params: type_expr list;
clty_type: class_type;
clty_path: Path.t;
- clty_variance: (bool * bool) list }
+ clty_variance: Variance.t list }
(* Type expressions for the module language *)
(* *)
(***********************************************************************)
-(* $Id: types.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Representation of types and declarations *)
open Asttypes
(* Constructor descriptions *)
type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
+ { cstr_name: string; (* Constructor name *)
+ cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
Record_regular (* All fields are boxed / tagged *)
| Record_float (* All fields are floats *)
+(* Variance *)
+
+module Variance : sig
+ type t
+ type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+ val null : t (* no occurence *)
+ val full : t (* strictly invariant *)
+ val covariant : t (* strictly covariant *)
+ val may_inv : t (* maybe invariant *)
+ val union : t -> t -> t
+ val inter : t -> t -> t
+ val subset : t -> t -> bool
+ val set : f -> bool -> t -> t
+ val mem : f -> t -> bool
+ val conjugate : t -> t (* exchange positive and negative *)
+ val get_upper : t -> bool * bool (* may_pos, may_neg *)
+ val get_lower : t -> bool * bool * bool * bool (* pos, neg, inv, inj *)
+end
+
(* Type definitions *)
type type_declaration =
type_kind: type_kind;
type_private: private_flag;
type_manifest: type_expr option;
- type_variance: (bool * bool * bool) list;
- (* covariant, contravariant, weakly contravariant *)
+ type_variance: Variance.t list;
+ (* covariant, contravariant, weakly contravariant, injective *)
type_newtype_level: (int * int) option;
(* definition level * expansion level *)
type_loc: Location.t }
(Ident.t * mutable_flag * type_expr) list * record_representation
| Type_variant of (Ident.t * type_expr list * type_expr option) list
+and type_transparence =
+ Type_public (* unrestricted expansion *)
+ | Type_new (* "new" type *)
+ | Type_private (* private type *)
+
type exception_declaration =
{ exn_args: type_expr list;
exn_loc: Location.t }
mutable cty_type: class_type;
cty_path: Path.t;
cty_new: type_expr option;
- cty_variance: (bool * bool) list }
+ cty_variance: Variance.t list }
type class_type_declaration =
{ clty_params: type_expr list;
clty_type: class_type;
clty_path: Path.t;
- clty_variance: (bool * bool) list }
+ clty_variance: Variance.t list }
(* Type expressions for the module language *)
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
| Ill_typed_functor_application of Longident.t
+ | Illegal_reference_to_recursive_module
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
type variable_context = int * (string, type_expr) Tbl.t
(* Narrowing unbound identifier errors. *)
-let rec narrow_unbound_lid_error env loc lid make_error =
+let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
+ fun env loc lid make_error ->
let check_module mlid =
try ignore (Env.lookup_module mlid env)
with Not_found ->
- narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid);
- assert false
+ narrow_unbound_lid_error env loc mlid
+ (fun lid -> Unbound_module lid)
+ | Env.Recmodule ->
+ raise (Error (loc, env, Illegal_reference_to_recursive_module))
in
begin match lid with
| Longident.Lident _ -> ()
| Longident.Lapply (flid, mlid) ->
check_module flid;
check_module mlid;
- raise (Error (loc, Ill_typed_functor_application lid))
+ raise (Error (loc, env, Ill_typed_functor_application lid))
end;
- raise (Error (loc, make_error lid))
+ raise (Error (loc, env, make_error lid))
let find_component lookup make_error env loc lid =
try
lookup (Longident.Lident s) Env.initial
| _ -> lookup lid env
with Not_found ->
- (narrow_unbound_lid_error env loc lid make_error
- : unit (* to avoid a warning *));
- assert false
+ narrow_unbound_lid_error env loc lid make_error
+ | Env.Recmodule ->
+ raise (Error (loc, env, Illegal_reference_to_recursive_module))
let find_type =
find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
let find_constructor =
find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
+let find_all_constructors =
+ find_component Env.lookup_all_constructors
+ (fun lid -> Unbound_constructor lid)
let find_label =
find_component Env.lookup_label (fun lid -> Unbound_label lid)
+let find_all_labels =
+ find_component Env.lookup_all_labels (fun lid -> Unbound_label lid)
let find_class =
find_component Env.lookup_class (fun lid -> Unbound_class lid)
let find_value =
let find_class_type =
find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
+let unbound_constructor_error env lid =
+ narrow_unbound_lid_error env lid.loc lid.txt
+ (fun lid -> Unbound_constructor lid)
+
+let unbound_label_error env lid =
+ narrow_unbound_lid_error env lid.loc lid.txt
+ (fun lid -> Unbound_label lid)
+
(* Support for first-class modules. *)
let transl_modtype_longident = ref (fun _ -> assert false)
List.sort
(fun (s1, t1) (s2, t2) ->
if s1.txt = s2.txt then
- raise (Error (loc, Multiple_constraints_on_type s1.txt));
+ raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
compare s1 s2)
l
in
let enter_type_variable strict loc name =
try
if name <> "" && name.[0] = '_' then
- raise (Error (loc, Invalid_variable_name ("'" ^ name)));
+ raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
let v = Tbl.find name !type_variables in
if strict then raise Already_bound;
v
try
Tbl.find name !type_variables
with Not_found ->
- raise(Error(loc, Unbound_type_variable ("'" ^ name)))
+ raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
let wrap_method ty =
match (Ctype.repr ty).desc with
let ty =
if policy = Univars then new_pre_univar () else
if policy = Fixed then
- raise (Error (styp.ptyp_loc, Unbound_type_variable "_"))
+ raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
else newvar ()
in
ctyp Ttyp_any ty env loc
| Ptyp_var name ->
let ty =
if name <> "" && name.[0] = '_' then
- raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
+ raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
begin try
instance env (List.assoc name !univars)
with Not_found -> try
| Ptyp_constr(lid, stl) ->
let (path, decl) = find_type env styp.ptyp_loc lid.txt in
if List.length stl <> decl.type_arity then
- raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity,
- List.length stl)));
+ raise(Error(styp.ptyp_loc, env,
+ Type_arity_mismatch(lid.txt, decl.type_arity,
+ List.length stl)));
let args = List.map (transl_type env policy) stl in
let params = instance_list decl.type_params in
let unify_param =
List.iter2
(fun (sty, cty) ty' ->
try unify_param env ty' cty.ctyp_type with Unify trace ->
- raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
+ raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
(List.combine stl args) params;
let constr =
newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
begin try
Ctype.enforce_constraints env constr
with Unify trace ->
- raise (Error(styp.ptyp_loc, Type_mismatch trace))
+ raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
end;
ctyp (Ttyp_constr (path, lid, args)) constr env loc
| Ptyp_object fields ->
check (Env.find_type path env)
| _ -> raise Not_found
in check decl;
- Location.prerr_warning styp.ptyp_loc Warnings.Deprecated;
+ Location.prerr_warning styp.ptyp_loc
+ (Warnings.Deprecated "old syntax for polymorphic variant type");
(path, decl,true)
with Not_found -> try
if present <> [] then raise Not_found;
let (path, decl) = Env.lookup_type lid2 env in
(path, decl, false)
with Not_found ->
- raise(Error(styp.ptyp_loc, Unbound_class lid.txt))
+ raise(Error(styp.ptyp_loc, env, Unbound_class lid.txt))
in
if List.length stl <> decl.type_arity then
- raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity,
- List.length stl)));
+ raise(Error(styp.ptyp_loc, env,
+ Type_arity_mismatch(lid.txt, decl.type_arity,
+ List.length stl)));
let args = List.map (transl_type env policy) stl in
let params = instance_list decl.type_params in
List.iter2
(fun (sty, cty) ty' ->
try unify_var env ty' cty.ctyp_type with Unify trace ->
- raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
+ raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
(List.combine stl args) params;
let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
let ty =
try Ctype.expand_head env (newconstr path ty_args)
with Unify trace ->
- raise (Error(styp.ptyp_loc, Type_mismatch trace))
+ raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
in
let ty = match ty.desc with
Tvariant row ->
let row = Btype.row_repr row in
List.iter
(fun l -> if not (List.mem_assoc l row.row_fields) then
- raise(Error(styp.ptyp_loc, Present_has_no_type l)))
+ raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
present;
let fields =
List.map
let ty = transl_type env policy st in
begin try unify_var env t ty.ctyp_type with Unify trace ->
let trace = swap_list trace in
- raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+ raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
end;
ty
with Not_found ->
let ty = transl_type env policy st in
begin try unify_var env t ty.ctyp_type with Unify trace ->
let trace = swap_list trace in
- raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+ raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
end;
if !Clflags.principal then begin
end_def ();
try
let (l',f') = Hashtbl.find hfields h in
(* Check for tag conflicts *)
- if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l')));
+ if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
let ty = mkfield l f and ty' = mkfield l f' in
if equal env false [ty] [ty'] then () else
try unify env ty ty'
- with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty')))
+ with Unify trace ->
+ raise(Error(loc, env, Constructor_mismatch (ty,ty')))
with Not_found ->
Hashtbl.add hfields h (l,f)
in
- let rec add_field = function
+ let add_field = function
Rtag (l, c, stl) ->
name := None;
let tl = List.map (transl_type env policy) stl in
Reither(c, ty_tl, false, ref None)
| _ ->
if List.length stl > 1 || c && stl <> [] then
- raise(Error(styp.ptyp_loc, Present_has_conjunction l));
+ raise(Error(styp.ptyp_loc, env, Present_has_conjunction l));
match tl with [] -> Rpresent None
| st :: _ ->
Rpresent (Some st.ctyp_type)
let row = Btype.row_repr row in
row.row_fields
| {desc=Tvar _}, Some(p, _) ->
- raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
+ raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p))
| _ ->
- raise(Error(sty.ptyp_loc, Not_a_variant ty))
+ raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
in
List.iter
(fun (l, f) ->
| Some present ->
List.iter
(fun l -> if not (List.mem_assoc l fields) then
- raise(Error(styp.ptyp_loc, Present_has_no_type l)))
+ raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
present
end;
let row =
v.desc <- Tunivar name;
v :: tyl
| _ ->
- raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
+ raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
end else tyl)
[] new_univars
in
| {field_desc = Tcfield_var}::_ ->
if policy = Univars then new_pre_univar () else newvar ()
| {field_desc = Tcfield(s, ty1); field_loc = loc}::l ->
- if List.mem s seen then raise (Error (loc, Repeated_method_label s));
+ if List.mem s seen then raise (Error (loc, env, Repeated_method_label s));
let ty2 = transl_fields env policy (s::seen) l in
newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2))
r := (loc, v, Tbl.find name !type_variables) :: !r
with Not_found ->
if fixed && Btype.is_Tvar (repr ty) then
- raise(Error(loc, Unbound_type_variable ("'"^name)));
+ raise(Error(loc, env, Unbound_type_variable ("'"^name)));
let v2 = new_global_var () in
r := (loc, v, v2) :: !r;
type_variables := Tbl.add name v2 !type_variables)
List.iter
(function (loc, t1, t2) ->
try unify env t1 t2 with Unify trace ->
- raise (Error(loc, Type_mismatch trace)))
+ raise (Error(loc, env, Type_mismatch trace)))
!r
let transl_simple_type env fixed styp =
open Format
open Printtyp
-let report_error ppf = function
+let spellcheck ppf fold env lid =
+ let cutoff =
+ match String.length (Longident.last lid) with
+ | 1 | 2 -> 0
+ | 3 | 4 -> 1
+ | 5 | 6 -> 2
+ | _ -> 3
+ in
+ let compare target head acc =
+ let (best_choice, best_dist) = acc in
+ match Misc.edit_distance target head cutoff with
+ | None -> (best_choice, best_dist)
+ | Some dist ->
+ let choice =
+ if dist < best_dist then [head]
+ else if dist = best_dist then head :: best_choice
+ else best_choice in
+ (choice, min dist best_dist)
+ in
+ let init = ([], max_int) in
+ let handle (choice, _dist) =
+ match List.rev choice with
+ | [] -> ()
+ | last :: rev_rest ->
+ fprintf ppf "@\nDid you mean %s%s%s?"
+ (String.concat ", " (List.rev rev_rest))
+ (if rev_rest = [] then "" else " or ")
+ last
+ in
+ (* flush now to get the error report early, in the (unheard of) case
+ where the linear search would take a bit of time; in the worst
+ case, the user has seen the error, she can interrupt the process
+ before the spell-checking terminates. *)
+ fprintf ppf "@?";
+ match lid with
+ | Longident.Lapply _ -> ()
+ | Longident.Lident s ->
+ handle (fold (compare s) None env init)
+ | Longident.Ldot (r, s) ->
+ handle (fold (compare s) (Some r) env init)
+
+let spellcheck_simple ppf fold extr =
+ spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) x))
+
+let spellcheck ppf fold =
+ spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
+
+type cd = string list * int
+
+let report_error env ppf = function
| Unbound_type_variable name ->
- fprintf ppf "Unbound type parameter %s" name
+ fprintf ppf "Unbound type parameter %s@." name
| Unbound_type_constructor lid ->
- fprintf ppf "Unbound type constructor %a" longident lid
+ fprintf ppf "Unbound type constructor %a" longident lid;
+ spellcheck ppf Env.fold_types env lid;
| Unbound_type_constructor_2 p ->
- fprintf ppf "The type constructor@ %a@ is not yet completely defined"
- path p
+ fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+ path p
| Type_arity_mismatch(lid, expected, provided) ->
- fprintf ppf
- "@[The type constructor %a@ expects %i argument(s),@ \
+ fprintf ppf
+ "@[The type constructor %a@ expects %i argument(s),@ \
but is here applied to %i argument(s)@]"
- longident lid expected provided
+ longident lid expected provided
| Bound_type_variable name ->
- fprintf ppf "Already bound type parameter '%s" name
+ fprintf ppf "Already bound type parameter '%s" name
| Recursive_type ->
- fprintf ppf "This type is recursive"
+ fprintf ppf "This type is recursive"
| Unbound_row_variable lid ->
+ (* we don't use "spellcheck" here: this error is not raised
+ anywhere so it's unclear how it should be handled *)
fprintf ppf "Unbound row variable in #%a" longident lid
| Type_mismatch trace ->
- Printtyp.unification_error true trace
+ Printtyp.report_unification_error ppf Env.empty trace
(function ppf ->
fprintf ppf "This type")
- ppf
(function ppf ->
fprintf ppf "should be an instance of type")
| Alias_type_mismatch trace ->
- Printtyp.unification_error true trace
+ Printtyp.report_unification_error ppf Env.empty trace
(function ppf ->
fprintf ppf "This alias is bound to type")
- ppf
(function ppf ->
fprintf ppf "but is used as an instance of type")
| Present_has_conjunction l ->
| Present_has_no_type l ->
fprintf ppf "The present constructor %s has no type" l
| Constructor_mismatch (ty, ty') ->
- Printtyp.reset_and_mark_loops_list [ty; ty'];
- fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
- "This variant type contains a constructor"
- Printtyp.type_expr ty
- "which should be"
- Printtyp.type_expr ty'
+ wrap_printing_env env (fun () ->
+ Printtyp.reset_and_mark_loops_list [ty; ty'];
+ fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
+ "This variant type contains a constructor"
+ Printtyp.type_expr ty
+ "which should be"
+ Printtyp.type_expr ty')
| Not_a_variant ty ->
Printtyp.reset_and_mark_loops ty;
fprintf ppf "@[The type %a@ is not a polymorphic variant type@]"
fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
s "Multiple occurences are not allowed."
| Unbound_value lid ->
- fprintf ppf "Unbound value %a" longident lid
+ fprintf ppf "Unbound value %a" longident lid;
+ spellcheck ppf Env.fold_values env lid;
| Unbound_module lid ->
- fprintf ppf "Unbound module %a" longident lid
+ fprintf ppf "Unbound module %a" longident lid;
+ spellcheck ppf Env.fold_modules env lid;
| Unbound_constructor lid ->
- fprintf ppf "Unbound constructor %a" longident lid
+ fprintf ppf "Unbound constructor %a" longident lid;
+ spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name)
+ env lid;
| Unbound_label lid ->
- fprintf ppf "Unbound record field label %a" longident lid
+ fprintf ppf "Unbound record field %a" longident lid;
+ spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid;
| Unbound_class lid ->
- fprintf ppf "Unbound class %a" longident lid
+ fprintf ppf "Unbound class %a" longident lid;
+ spellcheck ppf Env.fold_classs env lid;
| Unbound_modtype lid ->
- fprintf ppf "Unbound module type %a" longident lid
+ fprintf ppf "Unbound module type %a" longident lid;
+ spellcheck ppf Env.fold_modtypes env lid;
| Unbound_cltype lid ->
- fprintf ppf "Unbound class type %a" longident lid
+ fprintf ppf "Unbound class type %a" longident lid;
+ spellcheck ppf Env.fold_cltypes env lid;
| Ill_typed_functor_application lid ->
fprintf ppf "Ill-typed functor application %a" longident lid
+ | Illegal_reference_to_recursive_module ->
+ fprintf ppf "Illegal recursive module reference"
(* *)
(***********************************************************************)
-(* $Id: typetexp.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
(* Typechecking of type expressions for the core language *)
-open Format;;
+open Types
val transl_simple_type:
Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
val transl_type_scheme:
Env.t -> Parsetree.core_type -> Typedtree.core_type
val reset_type_variables: unit -> unit
-val enter_type_variable: bool -> Location.t -> string -> Types.type_expr
-val type_variable: Location.t -> string -> Types.type_expr
+val enter_type_variable: bool -> Location.t -> string -> type_expr
+val type_variable: Location.t -> string -> type_expr
type variable_context
val narrow: unit -> variable_context
| Bound_type_variable of string
| Recursive_type
| Unbound_row_variable of Longident.t
- | Type_mismatch of (Types.type_expr * Types.type_expr) list
- | Alias_type_mismatch of (Types.type_expr * Types.type_expr) list
+ | Type_mismatch of (type_expr * type_expr) list
+ | Alias_type_mismatch of (type_expr * type_expr) list
| Present_has_conjunction of string
| Present_has_no_type of string
- | Constructor_mismatch of Types.type_expr * Types.type_expr
- | Not_a_variant of Types.type_expr
+ | Constructor_mismatch of type_expr * type_expr
+ | Not_a_variant of type_expr
| Variant_tags of string * string
| Invalid_variable_name of string
- | Cannot_quantify of string * Types.type_expr
+ | Cannot_quantify of string * type_expr
| Multiple_constraints_on_type of Longident.t
| Repeated_method_label of string
| Unbound_value of Longident.t
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
| Ill_typed_functor_application of Longident.t
+ | Illegal_reference_to_recursive_module
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> Format.formatter -> error -> unit
(* Support for first-class modules. *)
val transl_modtype_longident: (* from Typemod *)
Parsetree.module_type
val find_type:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
+ Env.t -> Location.t -> Longident.t -> Path.t * type_declaration
val find_constructor:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.constructor_description
+ Env.t -> Location.t -> Longident.t -> constructor_description
+val find_all_constructors:
+ Env.t -> Location.t -> Longident.t ->
+ (constructor_description * (unit -> unit)) list
val find_label:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.label_description
+ Env.t -> Location.t -> Longident.t -> label_description
+val find_all_labels:
+ Env.t -> Location.t -> Longident.t ->
+ (label_description * (unit -> unit)) list
val find_value:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description
+ Env.t -> Location.t -> Longident.t -> Path.t * value_description
val find_class:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration
+ Env.t -> Location.t -> Longident.t -> Path.t * class_declaration
val find_module:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type
+ Env.t -> Location.t -> Longident.t -> Path.t * module_type
val find_modtype:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration
+ Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
val find_class_type:
- Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration
+ Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration
+
+val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
+val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a
+
+type cd
+val spellcheck_simple:
+ Format.formatter ->
+ (('a -> cd -> cd) -> Longident.t option -> 'b -> cd -> cd) ->
+ ('a -> string) -> 'b -> Longident.t -> unit
(* *)
(***********************************************************************)
-(* $Id: ccomp.ml 12027 2012-01-16 09:05:37Z frisch $ *)
-
(* Compiling C files and building C libraries *)
let command cmdline =
if !Clflags.native_code
then Config.native_c_compiler
else Config.bytecomp_c_compiler)
- (String.concat " " (List.rev !Clflags.ccopts))
+ (String.concat " " (List.rev !Clflags.all_ccopts))
(quote_prefixed "-I" (List.rev !Clflags.include_dirs))
(Clflags.std_include_flag "-I")
(Filename.quote name))
(if !Clflags.gprofile then Config.cc_profile else "")
"" (*(Clflags.std_include_flag "-I")*)
(quote_prefixed "-L" !Config.load_path)
- (String.concat " " (List.rev !Clflags.ccopts))
+ (String.concat " " (List.rev !Clflags.all_ccopts))
files
extra
in
(* *)
(***********************************************************************)
-(* $Id: ccomp.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Compiling C files and building C libraries *)
val command: string -> int
(* *)
(***********************************************************************)
-(* $Id: clflags.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Command-line parameters *)
let objfiles = ref ([] : string list) (* .cmo and .cma files *)
and fast = ref false (* -unsafe *)
and link_everything = ref false (* -linkall *)
and custom_runtime = ref false (* -custom *)
+and bytecode_compatible_32 = ref false (* -compat-32 *)
and output_c_object = ref false (* -output-obj *)
-and ccopts = ref ([] : string list) (* -ccopt *)
+and all_ccopts = ref ([] : string list) (* -ccopt *)
and classic = ref false (* -nolabels *)
and nopervasives = ref false (* -nopervasives *)
and preprocessor = ref(None : string option) (* -pp *)
+and all_ppx = ref ([] : string list) (* -ppx *)
let annotations = ref false (* -annot *)
let binary_annotations = ref false (* -annot *)
and use_threads = ref false (* -thread *)
and use_prims = ref "" (* -use-prims ... *)
and use_runtime = ref "" (* -use-runtime ... *)
and principal = ref false (* -principal *)
+and real_paths = ref true (* -short-paths *)
and recursive_types = ref false (* -rectypes *)
and strict_sequence = ref false (* -strict-sequence *)
and applicative_functors = ref true (* -no-app-funct *)
and make_package = ref false (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
and error_size = ref 500 (* -error-size *)
+let dump_source = ref false (* -dsource *)
let dump_parsetree = ref false (* -dparsetree *)
+and dump_typedtree = ref false (* -dtypedtree *)
and dump_rawlambda = ref false (* -drawlambda *)
and dump_lambda = ref false (* -dlambda *)
and dump_clambda = ref false (* -dclambda *)
let dump_live = ref false (* -dlive *)
let dump_spill = ref false (* -dspill *)
let dump_split = ref false (* -dsplit *)
-let dump_scheduling = ref false (* -dscheduling *)
let dump_interf = ref false (* -dinterf *)
let dump_prefer = ref false (* -dprefer *)
let dump_regalloc = ref false (* -dalloc *)
let native_code = ref false (* set to true under ocamlopt *)
let inline_threshold = ref 10
+let force_slash = ref false (* for ocamldep *)
let dont_write_files = ref false (* set to true under ocamldoc *)
let shared = ref false (* -shared *)
let dlcode = ref true (* not -nodynlink *)
-let runtime_variant = ref "";; (* -runtime-variant *)
+let runtime_variant = ref "";; (* -runtime-variant *)
(* *)
(***********************************************************************)
-(* $Id: clflags.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
val objfiles : string list ref
val ccobjs : string list ref
val dllibs : string list ref
val fast : bool ref
val link_everything : bool ref
val custom_runtime : bool ref
+val bytecode_compatible_32: bool ref
val output_c_object : bool ref
-val ccopts : string list ref
+val all_ccopts : string list ref
val classic : bool ref
val nopervasives : bool ref
val preprocessor : string option ref
+val all_ppx : string list ref
val annotations : bool ref
val binary_annotations : bool ref
val use_threads : bool ref
val use_prims : string ref
val use_runtime : string ref
val principal : bool ref
+val real_paths : bool ref
val recursive_types : bool ref
val strict_sequence : bool ref
val applicative_functors : bool ref
val make_package : bool ref
val for_package : string option ref
val error_size : int ref
+val dump_source : bool ref
val dump_parsetree : bool ref
+val dump_typedtree : bool ref
val dump_rawlambda : bool ref
val dump_lambda : bool ref
val dump_clambda : bool ref
val shared : bool ref
val dlcode : bool ref
val runtime_variant : string ref
+val force_slash : bool ref
(* *)
(***********************************************************************)
-(* $Id: config.mlbuild 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(***********************************************************************)
(** **)
(** WARNING WARNING WARNING **)
if windows then "ocamlrun"
else C.bindir^"/ocamlrun"
let ccomp_type = C.ccomptype
-let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts
+let bytecomp_c_compiler =
+ sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts
let bytecomp_c_libraries = C.bytecclibs
let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts
let native_c_libraries = C.nativecclibs
let mkmaindll = C.mkmaindll
let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I014"
+and cmi_magic_number = "Caml1999I015"
and cmo_magic_number = "Caml1999O007"
and cma_magic_number = "Caml1999A008"
and cmx_magic_number = "Caml1999Y011"
and cmxa_magic_number = "Caml1999Z010"
-and ast_impl_magic_number = "Caml1999M015"
-and ast_intf_magic_number = "Caml1999N014"
+and ast_impl_magic_number = "Caml1999M016"
+and ast_intf_magic_number = "Caml1999N015"
and cmxs_magic_number = "Caml2007D001"
-and cmt_magic_number = "Caml2012T001"
+and cmt_magic_number = "Caml2012T002"
let load_path = ref ([] : string list)
p "os_type" Sys.os_type;
p "default_executable_name" default_executable_name;
p_bool "systhread_supported" systhread_supported;
+ p "exec_magic_number" exec_magic_number;
+ p "cmi_magic_number" cmi_magic_number;
+ p "cmo_magic_number" cmo_magic_number;
+ p "cma_magic_number" cma_magic_number;
+ p "cmx_magic_number" cmx_magic_number;
+ p "cmxa_magic_number" cmxa_magic_number;
+ p "ast_impl_magic_number" ast_impl_magic_number;
+ p "ast_intf_magic_number" ast_intf_magic_number;
+ p "cmxs_magic_number" cmxs_magic_number;
+ p "cmt_magic_number" cmt_magic_number;
+
flush oc;
;;
(* *)
(***********************************************************************)
-(* $Id: config.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* System configuration *)
val version: string
val native_c_libraries: string
(* The C libraries to link with native-code programs *)
val native_pack_linker: string
- (* The linker to use for packaging (ocamlopt -pack) and for partial links
- (ocamlopt -output-obj). *)
+ (* The linker to use for packaging (ocamlopt -pack) and for partial
+ links (ocamlopt -output-obj). *)
val mkdll: string
(* The linker command line to build dynamic libraries. *)
val mkexe: string
val asm_cfi_supported: bool
(* Whether assembler understands CFI directives *)
+val with_frame_pointers : bool
+ (* Whether assembler should maintain frame pointers *)
val ext_obj: string
(* Extension for object files, e.g. [.o] under Unix. *)
(* *)
(***********************************************************************)
-(* $Id: config.mlp 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(***********************************************************************)
(** **)
(** WARNING WARNING WARNING **)
let mkmaindll = "%%MKMAINDLL%%"
let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I014"
+and cmi_magic_number = "Caml1999I015"
and cmo_magic_number = "Caml1999O007"
and cma_magic_number = "Caml1999A008"
and cmx_magic_number = "Caml1999Y011"
and cmxa_magic_number = "Caml1999Z010"
-and ast_impl_magic_number = "Caml1999M015"
-and ast_intf_magic_number = "Caml1999N014"
+and ast_impl_magic_number = "Caml1999M016"
+and ast_intf_magic_number = "Caml1999N015"
and cmxs_magic_number = "Caml2007D001"
-and cmt_magic_number = "Caml2012T001"
+and cmt_magic_number = "Caml2012T002"
let load_path = ref ([] : string list)
let asm = "%%ASM%%"
let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
let ext_obj = "%%EXT_OBJ%%"
let ext_asm = "%%EXT_ASM%%"
p "system" system;
p "asm" asm;
p_bool "asm_cfi_supported" asm_cfi_supported;
+ p_bool "with_frame_pointers" with_frame_pointers;
p "ext_obj" ext_obj;
p "ext_asm" ext_asm;
p "ext_lib" ext_lib;
p "os_type" Sys.os_type;
p "default_executable_name" default_executable_name;
p_bool "systhread_supported" systhread_supported;
+
+ (* print the magic number *)
+ p "exec_magic_number" exec_magic_number;
+ p "cmi_magic_number" cmi_magic_number;
+ p "cmo_magic_number" cmo_magic_number;
+ p "cma_magic_number" cma_magic_number;
+ p "cmx_magic_number" cmx_magic_number;
+ p "cmxa_magic_number" cmxa_magic_number;
+ p "ast_impl_magic_number" ast_impl_magic_number;
+ p "ast_intf_magic_number" ast_intf_magic_number;
+ p "cmxs_magic_number" cmxs_magic_number;
+ p "cmt_magic_number" cmt_magic_number;
+
flush oc;
;;
(* *)
(***********************************************************************)
-(* $Id: consistbl.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Consistency tables: for checking consistency of module CRCs *)
type t = (string, Digest.t * string) Hashtbl.t
(* *)
(***********************************************************************)
-(* $Id: consistbl.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Consistency tables: for checking consistency of module CRCs *)
type t
(* *)
(***********************************************************************)
-(* $Id: misc.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
(* Errors *)
exception Fatal_error
let fst4 (x, _, _, _) = x
let snd4 (_,x,_, _) = x
let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+ type t = string array
+
+ let create str_size =
+ let tbl_size = str_size / Sys.max_string_length + 1 in
+ let tbl = Array.make tbl_size "" in
+ for i = 0 to tbl_size - 2 do
+ tbl.(i) <- String.create Sys.max_string_length;
+ done;
+ tbl.(tbl_size - 1) <- String.create (str_size mod Sys.max_string_length);
+ tbl
+
+ let length tbl =
+ let tbl_size = Array.length tbl in
+ Sys.max_string_length * (tbl_size - 1) + String.length tbl.(tbl_size - 1)
+
+ let get tbl ind =
+ tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length]
+
+ let set tbl ind c =
+ tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] <- c
+
+ let blit src srcoff dst dstoff len =
+ for i = 0 to len - 1 do
+ set dst (dstoff + i) (get src (srcoff + i))
+ done
+
+ let output oc tbl pos len =
+ for i = pos to pos + len - 1 do
+ output_char oc (get tbl i)
+ done
+
+ let unsafe_blit_to_string src srcoff dst dstoff len =
+ for i = 0 to len - 1 do
+ String.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+ done
+
+ let input_bytes ic len =
+ let tbl = create len in
+ Array.iter (fun str -> really_input ic str 0 (String.length str)) tbl;
+ tbl
+end
+
+
+let edit_distance a b cutoff =
+ let la, lb = String.length a, String.length b in
+ let cutoff =
+ (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+ we bring it back to the (max la lb) worstcase *)
+ min (max la lb) cutoff in
+ if abs (la - lb) > cutoff then None
+ else begin
+ (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+ the worst possible cost; this is useful when computing the cost of
+ a case just at the boundary of the cutoff diagonal. *)
+ let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+ m.(0).(0) <- 0;
+ for i = 1 to la do
+ m.(i).(0) <- i;
+ done;
+ for j = 1 to lb do
+ m.(0).(j) <- j;
+ done;
+ for i = 1 to la do
+ for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+ let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+ let best =
+ (* insert, delete or substitute *)
+ min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+ in
+ let best =
+ (* swap two adjacent letters; we use "cost" again in case of
+ a swap between two identical letters; this is slightly
+ redundant as this is a double-substitution case, but it
+ was done this way in most online implementations and
+ imitation has its virtues *)
+ if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+ then best
+ else min best (m.(i-2).(j-2) + cost)
+ in
+ m.(i).(j) <- best
+ done;
+ done;
+ let result = m.(la).(lb) in
+ if result > cutoff
+ then None
+ else Some result
+ end
+
+
+(* split a string [s] at every char [c], and return the list of sub-strings *)
+let split s c =
+ let len = String.length s in
+ let rec iter pos to_rev =
+ if pos = len then List.rev ("" :: to_rev) else
+ match try
+ Some ( String.index_from s pos c )
+ with Not_found -> None
+ with
+ Some pos2 ->
+ if pos2 = pos then iter (pos+1) ("" :: to_rev) else
+ iter (pos2+1) ((String.sub s pos (pos2-pos)) :: to_rev)
+ | None -> List.rev ( String.sub s pos (len-pos) :: to_rev )
+ in
+ iter 0 []
+
+let cut_at s c =
+ let pos = String.index s c in
+ String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
(* *)
(***********************************************************************)
-(* $Id: misc.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
(* Miscellaneous useful types and functions *)
val fatal_error: string -> 'a
val fst4: 'a * 'b * 'c * 'd -> 'a
val snd4: 'a * 'b * 'c * 'd -> 'b
val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+ sig
+ type t = string array
+ val create : int -> t
+ val length : t -> int
+ val get : t -> int -> char
+ val set : t -> int -> char -> unit
+ val blit : t -> int -> t -> int -> int -> unit
+ val output : out_channel -> t -> int -> int -> unit
+ val unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+ val input_bytes : in_channel -> int -> t
+ end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+ strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+ distance [d] is smaller than [cutoff], it returns [Some d], else
+ [None].
+
+ The distance algorithm currently used is Damerau-Levenshtein: it
+ computes the number of insertion, deletion, substitution of
+ letters, or swapping of adjacent letters to go from one word to the
+ other. The particular algorithm may change in the future.
+*)
+
+val split : string -> char -> string list
+(** [String.split string char] splits the string [string] at every char
+ [char], and returns the list of sub-strings between the chars.
+ [String.concat (String.make 1 c) (String.split s c)] is the identity.
+ @since 4.01
+ *)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+ the first occurrence of [c] in [s], and the sub-string after the
+ first occurrence of [c] in [s].
+ [let (before, after) = String.cut_at s c in
+ before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+ Raise [Not_found] if the character does not appear in the string
+ @since 4.01
+*)
(* *)
(***********************************************************************)
-(* $Id: tbl.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
type ('a, 'b) t =
Empty
| Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int
(* *)
(***********************************************************************)
-(* $Id: tbl.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Association tables from any ordered type to any type.
We use the generic ordering to compare keys. *)
(* *)
(***********************************************************************)
-(* $Id: terminfo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Basic interface to the terminfo database *)
type status =
(* *)
(***********************************************************************)
-(* $Id: terminfo.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
(* Basic interface to the terminfo database *)
type status =
(* *)
(***********************************************************************)
-(* $Id: warnings.ml 12504 2012-05-29 12:35:17Z frisch $ *)
-
(* When you change this, you need to update the documentation:
- man/ocamlc.m in ocaml
- man/ocamlopt.m in ocaml
type t =
| Comment_start (* 1 *)
| Comment_not_end (* 2 *)
- | Deprecated (* 3 *)
+ | Deprecated of string (* 3 *)
| Fragile_match of string (* 4 *)
| Partial_application (* 5 *)
| Labels_omitted (* 6 *)
| Unused_constructor of string * bool * bool (* 37 *)
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
+ | Name_out_of_scope of string * string list * bool (* 40 *)
+ | Ambiguous_name of string list * string list * bool (* 41 *)
+ | Disambiguated_name of string (* 42 *)
+ | Nonoptional_label of string (* 43 *)
+ | Open_shadow_identifier of string * string (* 44 *)
+ | Open_shadow_label_constructor of string * string (* 45 *)
+ | Bad_env_variable of string * string (* 46 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
let number = function
| Comment_start -> 1
| Comment_not_end -> 2
- | Deprecated -> 3
+ | Deprecated _ -> 3
| Fragile_match _ -> 4
| Partial_application -> 5
| Labels_omitted -> 6
| Unused_constructor _ -> 37
| Unused_exception _ -> 38
| Unused_rec_flag -> 39
+ | Name_out_of_scope _ -> 40
+ | Ambiguous_name _ -> 41
+ | Disambiguated_name _ -> 42
+ | Nonoptional_label _ -> 43
+ | Open_shadow_identifier _ -> 44
+ | Open_shadow_label_constructor _ -> 45
+ | Bad_env_variable _ -> 46
;;
-let last_warning_number = 39
+let last_warning_number = 46
(* Must be the max number returned by the [number] function. *)
let letter = function
let parse_options errflag s = parse_opt (if errflag then error else active) s;;
(* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29-32..39";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45";;
let defaults_warn_error = "-a";;
let () = parse_options false defaults_w;;
let message = function
| Comment_start -> "this is the start of a comment."
| Comment_not_end -> "this is not the end of a comment."
- | Deprecated -> "this syntax is deprecated."
+ | Deprecated s -> "deprecated feature: " ^ s
| Fragile_match "" ->
"this pattern-matching is fragile."
| Fragile_match s ->
(However, this constructor appears in patterns.)"
| Unused_rec_flag ->
"unused rec flag."
+ | Name_out_of_scope (ty, [nm], false) ->
+ nm ^ " was selected from type " ^ ty ^
+ ".\nIt is not visible in the current scope, and will not \n\
+ be selected if the type becomes unknown."
+ | Name_out_of_scope (_, _, false) -> assert false
+ | Name_out_of_scope (ty, slist, true) ->
+ "this record of type "^ ty ^" contains fields that are \n\
+ not visible in the current scope: "
+ ^ String.concat " " slist ^ ".\n\
+ They will not be selected if the type becomes unknown."
+ | Ambiguous_name ([s], tl, false) ->
+ s ^ " belongs to several types: " ^ String.concat " " tl ^
+ "\nThe first one was selected. Please disambiguate if this is wrong."
+ | Ambiguous_name (_, _, false) -> assert false
+ | Ambiguous_name (slist, tl, true) ->
+ "these field labels belong to several types: " ^
+ String.concat " " tl ^
+ "\nThe first one was selected. Please disambiguate if this is wrong."
+ | Disambiguated_name s ->
+ "this use of " ^ s ^ " required disambiguation."
+ | Nonoptional_label s ->
+ "the label " ^ s ^ " is not optional."
+ | Open_shadow_identifier (kind, s) ->
+ Printf.sprintf
+ "this open statement shadows the %s identifier %s (which is later used)"
+ kind s
+ | Open_shadow_label_constructor (kind, s) ->
+ Printf.sprintf
+ "this open statement shadows the %s %s (which is later used)"
+ kind s
+ | Bad_env_variable (var, s) ->
+ Printf.sprintf "illegal environment variable %s : %s" var s
;;
let nerrors = ref 0;;
[
1, "Suspicious-looking start-of-comment mark.";
2, "Suspicious-looking end-of-comment mark.";
- 3, "Deprecated syntax.";
+ 3, "Deprecated feature.";
4, "Fragile pattern matching: matching that will remain complete even\n\
\ if additional constructors are added to one of the variant types\n\
\ matched.";
37, "Unused constructor.";
38, "Unused exception constructor.";
39, "Unused rec flag.";
+ 40, "Constructor or label name used out of scope.";
+ 41, "Ambiguous constructor or label name.";
+ 42, "Disambiguated constructor or label name.";
+ 43, "Nonoptional label applied as optional.";
+ 44, "Open statement shadows an already defined identifier.";
+ 45, "Open statement shadows an already defined label or constructor.";
]
;;
(* *)
(***********************************************************************)
-(* $Id: warnings.mli 12504 2012-05-29 12:35:17Z frisch $ *)
-
open Format
type t =
| Comment_start (* 1 *)
| Comment_not_end (* 2 *)
- | Deprecated (* 3 *)
+ | Deprecated of string (* 3 *)
| Fragile_match of string (* 4 *)
| Partial_application (* 5 *)
| Labels_omitted (* 6 *)
| Unused_var_strict of string (* 27 *)
| Wildcard_arg_to_constant_constr (* 28 *)
| Eol_in_string (* 29 *)
- | Duplicate_definitions of string * string * string * string (*30 *)
+ | Duplicate_definitions of string * string * string * string (* 30 *)
| Multiple_definition of string * string * string (* 31 *)
| Unused_value_declaration of string (* 32 *)
| Unused_open of string (* 33 *)
| Unused_type_declaration of string (* 34 *)
| Unused_for_index of string (* 35 *)
| Unused_ancestor of string (* 36 *)
- | Unused_constructor of string * bool * bool (* 37 *)
+ | Unused_constructor of string * bool * bool (* 37 *)
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
+ | Name_out_of_scope of string * string list * bool (* 40 *)
+ | Ambiguous_name of string list * string list * bool (* 41 *)
+ | Disambiguated_name of string (* 42 *)
+ | Nonoptional_label of string (* 43 *)
+ | Open_shadow_identifier of string * string (* 44 *)
+ | Open_shadow_label_constructor of string * string (* 45 *)
+ | Bad_env_variable of string * string
;;
val parse_options : bool -> string -> unit;;
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the parser generator.
include ../config/Makefile
all: ocamlyacc$(EXE)
ocamlyacc$(EXE): $(OBJS)
- $(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc $(OBJS)
+ $(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc$(EXE) $(OBJS)
version.h : ../VERSION
echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
# #
#########################################################################
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
# Makefile for the parser generator.
include ../config/Makefile
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: closure.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "defs.h"
short *itemset;
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: defs.h 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <assert.h>
#include <ctype.h>
#include <errno.h>
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: error.c 11156 2011-07-27 14:17:02Z doligez $ */
-
/* routines for printing error messages */
#include "defs.h"
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: lalr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "defs.h"
typedef
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: lr0.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-
#include "defs.h"
extern short *itemset;
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: main.c 12800 2012-07-30 18:59:07Z doligez $ */
-
#include <signal.h>
#include <string.h>
#include "defs.h"
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: mkpar.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-
#include "defs.h"
action **parser;
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: output.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "defs.h"
static int nvectors;
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: reader.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include "defs.h"
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: skeleton.c 12834 2012-08-06 14:16:24Z doligez $ */
-
#include "defs.h"
char *header[] =
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: symtab.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include <string.h>
#include "defs.h"
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: verbose.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-
#include "defs.h"
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: warshall.c 11156 2011-07-27 14:17:02Z doligez $ */
-
#include "defs.h"
void transitive_closure(unsigned int *R, int n)
projects / ocaml.git / commitdiff